491 SUBROUTINE zdrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
492 $ NIUNIT, NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR,
493 $ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
494 $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
495 $ WORK, NWORK, RWORK, INFO )
502 INTEGER INFO, LDA, LDLRE, , LDVR, NIUNIT, NOUNIT,
503 $ NSIZES, NTYPES, NWORK
504 DOUBLE PRECISION THRESH
508 INTEGER ISEED( 4 ), NN( * )
509 DOUBLE PRECISION RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
510 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
511 $ result( 11 ), rwork( * ), scale( * ),
513 COMPLEX*16 A( , * ), H( LDA, * ), LRE( LDLRE, * ),
514 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
522 PARAMETER ( CZERO = ( 0.0d+0, 0.0d+0 ) )
524 PARAMETER ( CONE = ( 1.0d+0, 0.0d+0 ) )
525 DOUBLE PRECISION ZERO, ONE
526 parameter( zero = 0.0d+0, one = 1.0d+0 )
528 parameter( maxtyp = 21 )
534 INTEGER I, IBAL, IINFO, , ISRT, ITYPE, IWK, J,
535 $ jcol, jsize, jtype, mtypes, n, nerrs, nfail,
536 $ nmax, nnwork, ntest, ntestf, ntestt
537 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
538 $ ulpinv, unfl, wi, wr
542 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
543 $ KMAGN( MAXTYP ), KMODE( ),
547 DOUBLE PRECISION DLAMCH
555 INTRINSIC abs, dcmplx,
max,
min, sqrt
558 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
559 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
561 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
562 $ 1, 5, 5, 5, 4, 3, 1 /
563 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
564 DATA bal /
'N',
'P',
'S',
'B' /
568 path( 1: 1 ) =
'Zomplex precision'
586 nmax =
max( nmax, nn( j ) )
593 IF( nsizes.LT.0 )
THEN
595 ELSE IF( badnn )
THEN
597 ELSE IF( ntypes.LT.0 )
THEN
599 ELSE IF( thresh.LT.zero )
THEN
601 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
603 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
605 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
607 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
609 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
614 CALL xerbla(
'ZDRVVX', -info )
620 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
625 unfl = dlamch(
'Safe minimum' )
628 ulp = dlamch(
'Precision' )
637 DO 150 jsize = 1, nsizes
639 IF( nsizes.NE.1 )
THEN
640 mtypes =
min( maxtyp, ntypes )
642 mtypes =
min( maxtyp+1, ntypes )
645 DO 140 jtype = 1, mtypes
646 IF( .NOT.dotype( jtype ) )
652 ioldsd( j ) = iseed( j )
671 IF( mtypes.GT.maxtyp )
674 itype = ktype( jtype )
675 imode = kmode( jtype )
679 GO TO ( 30, 40, 50 )kmagn( jtype )
695 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
703 IF( itype.EQ.1 )
THEN
706 ELSE IF( itype.EQ.2 )
THEN
711 a( jcol, jcol ) = anorm
714 ELSE IF( itype.EQ.3 )
THEN
719 a( jcol, jcol ) = anorm
721 $ a( jcol, jcol-1 ) = one
724 ELSE IF( itype.EQ.4 )
THEN
728 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
729 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
732 ELSE IF( itype.EQ.5 )
THEN
736 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
737 $ anorm, n, n,
'N', a, lda, work( n+1 ),
740 ELSE IF( itype.EQ.6 )
THEN
744 IF( kconds( jtype ).EQ.1 )
THEN
746 ELSE IF( kconds( jtype ).EQ.2 )
THEN
752 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
753 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
754 $ a, lda, work( 2*n+1 ), iinfo )
756 ELSE IF( itype.EQ.7 )
THEN
760 CALL zlatmr( n, n,
'D', iseed,
'S', work, 6, one, cone,
761 $
'T',
'N', work( n+1 ), 1, one,
762 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
763 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
765 ELSE IF( itype.EQ.8 )
THEN
769 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
770 $
'T',
'N', work( n+1 ), 1, one,
771 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
772 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
774 ELSE IF( itype.EQ.9 )
THEN
778 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
779 $
'T',
'N', work( n+1 ), 1, one,
780 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
781 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
783 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
784 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
786 CALL zlaset(
'Full', n-3, 2, czero, czero,
788 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
792 ELSE IF( itype.EQ.10 )
THEN
796 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
797 $
'T', 'n
', WORK( N+1 ), 1, ONE,
798 $ WORK( 2*N+1 ), 1, ONE, 'n
', IDUMMA, N, 0,
799 $ ZERO, ANORM, 'no
', A, LDA, IDUMMA, IINFO )
806.NE.
IF( IINFO0 ) THEN
807 WRITE( NOUNIT, FMT = 9992 )'generator
', IINFO, N, JTYPE,
820.EQ.
ELSE IF( IWK2 ) THEN
823 NNWORK = 6*N + 2*N**2
825 NNWORK = MAX( NNWORK, 1 )
834 CALL ZGET23( .FALSE., 0, BALANC, JTYPE, THRESH,
835 $ IOLDSD, NOUNIT, N, A, LDA, H, W, W1, VL,
836 $ LDVL, VR, LDVR, LRE, LDLRE, RCONDV,
837 $ RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
838 $ SCALE, SCALE1, RESULT, WORK, NNWORK,
846.GE.
IF( RESULT( J )ZERO )
848.GE.
IF( RESULT( J )THRESH )
853 $ NTESTF = NTESTF + 1
854.EQ.
IF( NTESTF1 ) THEN
855 WRITE( NOUNIT, FMT = 9999 )PATH
856 WRITE( NOUNIT, FMT = 9998 )
857 WRITE( NOUNIT, FMT = 9997 )
858 WRITE( NOUNIT, FMT = 9996 )
859 WRITE( NOUNIT, FMT = 9995 )THRESH
864.GE.
IF( RESULT( J )THRESH ) THEN
865 WRITE( NOUNIT, FMT = 9994 )BALANC, N, IWK,
866 $ IOLDSD, JTYPE, J, RESULT( J )
870 NERRS = NERRS + NFAIL
871 NTESTT = NTESTT + NTEST
886 READ( NIUNIT, FMT = *, END = 220 )N, ISRT
895 READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
898 READ( NIUNIT, FMT = * )WR, WI, RCDEIN( I ), RCDVIN( I )
899 W1( I ) = DCMPLX( WR, WI )
901 CALL ZGET23( .TRUE., ISRT, 'n
', 22, THRESH, ISEED, NOUNIT, N, A,
902 $ LDA, H, W, W1, VL, LDVL, VR, LDVR, LRE, LDLRE,
903 $ RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
904 $ SCALE, SCALE1, RESULT, WORK, 6*N+2*N**2, RWORK,
912.GE.
IF( RESULT( J )ZERO )
914.GE.
IF( RESULT( J )THRESH )
919 $ NTESTF = NTESTF + 1
920.EQ.
IF( NTESTF1 ) THEN
921 WRITE( NOUNIT, FMT = 9999 )PATH
922 WRITE( NOUNIT, FMT = 9998 )
923 WRITE( NOUNIT, FMT = 9997 )
924 WRITE( NOUNIT, FMT = 9996 )
925 WRITE( NOUNIT, FMT = 9995 )THRESH
930.GE.
IF( RESULT( J )THRESH ) THEN
931 WRITE( NOUNIT, FMT = 9993 )N, JTYPE, J, RESULT( J )
935 NERRS = NERRS + NFAIL
936 NTESTT = NTESTT + NTEST
942 CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
944 9999 FORMAT( / 1X, A3, ' --
Complex Eigenvalue-Eigenvector
',
945 $ 'Decomposition Expert Driver
',
946 $ / ' Matrix types (see ZDRVVX for details):
' )
948 9998 FORMAT( / ' Special Matrices:
', / ' 1=zero matrix.
',
949 $ ' ', ' 5=diagonal: geometr. spaced entries.
',
950 $ / ' 2=identity matrix.
', ' 6=diagona
',
951 $ 'l: clustered entries.
', / ' 3=transposed jordan block.
',
952 $ ' ', ' 7=diagonal: large, evenly spaced.
', / ' ',
953 $ '4=diagonal: evenly spaced entries.
', ' 8=diagonal: s
',
954 $ 'mall, evenly spaced.
' )
955 9997 FORMAT( ' dense, non-symmetric matrices:
', / ' 9=well-cond., ev
',
956 $ 'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
957 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
958 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
959 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
960 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
961 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
962 $
'tioned, evenly spaced. ', ' 18=ill-cond., small rand.
',
964 9996 FORMAT( ' 19=matrix with random o(1) entries.
', ' 21=matrix
',
965 $ 'with small random entries.
', / ' 20=matrix with large ran
',
966 $ 'dom entries.
', ' 22=matrix
read from input file
', / )
967 9995 FORMAT( ' tests performed with test threshold =
', F8.2,
968 $ / / ' 1 = | a vr - vr w | / ( n |a| ulp )
',
969 $ / ' 2 = | transpose(a) vl - vl w | / ( n |a| ulp )
',
970 $ / ' 3 = | |vr(i)| - 1 | / ulp
',
971 $ / ' 4 = | |vl(i)| - 1 | / ulp
',
972 $ / ' 5 = 0
if w same no matter
if vr or vl computed,
',
973 $ ' 1/ulp otherwise
', /
974 $ ' 6 = 0
if vr same no matter what
else computed,
',
975 $ ' 1/ulp otherwise
', /
976 $ ' 7 = 0
if vl same no matter what
else computed,
',
977 $ ' 1/ulp otherwise
', /
978 $ ' 8 = 0
if rcondv same no matter what
else computed,
',
979 $ ' 1/ulp otherwise
', /
980 $ ' 9 = 0
if scale, ilo, ihi, abnrm same no matter what else
',
981 $ ' computed, 1/ulp otherwise
',
982 $ / ' 10 = | rcondv - rcondv(precomputed) | / cond(rcondv),
',
983 $ / ' 11 = | rconde - rconde(precomputed) | / cond
' )
984 9994 FORMAT( ' balanc=
''', A1, ''',n=
', I4, ',iwk=
', I1, ',
seed=
',
985 $ 4( I4, ',
' ), ' type ', I2, ', test(
', I2, ')=
', G10.3 )
986 9993 FORMAT( ' n=
', I5, ', input example =
', I3, ', test(
', I2, ')=
',
988 9992 FORMAT( ' zdrvvx:
', A, ' returned info=
', I6, '.
', / 9X, 'n=
',
989 $ I6, ', jtype=
', I6, ', iseed=(
', 3( I5, ',
' ), I5, ')
' )
subroutine zget23(comp, isrt, balanc, jtype, thresh, iseed, nounit, n, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, lwork, rwork, info)
ZGET23
subroutine zdrvvx(nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, nwork, rwork, info)
ZDRVVX