493 SUBROUTINE zdrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
494 $ niunit, nounit, a, lda, h, w, w1, vl, ldvl, vr,
495 $ ldvr, lre, ldlre, rcondv, rcndv1, rcdvin,
496 $ rconde, rcnde1, rcdein, scale, scale1, result,
497 $ work, nwork, rwork, info )
505 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
506 $ nsizes, ntypes, nwork
507 DOUBLE PRECISION THRESH
511 INTEGER ISEED( 4 ), NN( * )
512 DOUBLE PRECISION RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
513 $ rcndv1( * ), rconde( * ), rcondv( * ),
514 $ result( 11 ), rwork( * ), scale( * ),
516 COMPLEX*16 A( lda, * ), H( lda, * ), LRE( ldlre, * ),
517 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
525 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
527 parameter ( cone = ( 1.0d+0, 0.0d+0 ) )
528 DOUBLE PRECISION ZERO, ONE
529 parameter ( zero = 0.0d+0, one = 1.0d+0 )
531 parameter ( maxtyp = 21 )
537 INTEGER I, IBAL, IINFO, IMODE, ISRT, ITYPE, IWK, J,
538 $ jcol, jsize, jtype, mtypes, n, nerrs, nfail,
539 $ nmax, nnwork, ntest, ntestf, ntestt
540 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
541 $ ulpinv, unfl, wi, wr
545 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
546 $ kmagn( maxtyp ), kmode( maxtyp ),
550 DOUBLE PRECISION DLAMCH
558 INTRINSIC abs, dcmplx, max, min, sqrt
561 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
562 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
564 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
565 $ 1, 5, 5, 5, 4, 3, 1 /
566 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
567 DATA bal /
'N',
'P',
'S',
'B' /
571 path( 1: 1 ) =
'Zomplex precision'
589 nmax = max( nmax, nn( j ) )
596 IF( nsizes.LT.0 )
THEN
598 ELSE IF( badnn )
THEN
600 ELSE IF( ntypes.LT.0 )
THEN
602 ELSE IF( thresh.LT.zero )
THEN
604 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
606 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
608 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
610 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
612 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
617 CALL xerbla(
'ZDRVVX', -info )
623 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
628 unfl = dlamch(
'Safe minimum' )
631 ulp = dlamch(
'Precision' )
640 DO 150 jsize = 1, nsizes
642 IF( nsizes.NE.1 )
THEN
643 mtypes = min( maxtyp, ntypes )
645 mtypes = min( maxtyp+1, ntypes )
648 DO 140 jtype = 1, mtypes
649 IF( .NOT.dotype( jtype ) )
655 ioldsd( j ) = iseed( j )
674 IF( mtypes.GT.maxtyp )
677 itype = ktype( jtype )
678 imode = kmode( jtype )
682 GO TO ( 30, 40, 50 )kmagn( jtype )
698 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
706 IF( itype.EQ.1 )
THEN
709 ELSE IF( itype.EQ.2 )
THEN
714 a( jcol, jcol ) = anorm
717 ELSE IF( itype.EQ.3 )
THEN
722 a( jcol, jcol ) = anorm
724 $ a( jcol, jcol-1 ) = one
727 ELSE IF( itype.EQ.4 )
THEN
731 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
732 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
735 ELSE IF( itype.EQ.5 )
THEN
739 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
740 $ anorm, n, n,
'N', a, lda, work( n+1 ),
743 ELSE IF( itype.EQ.6 )
THEN
747 IF( kconds( jtype ).EQ.1 )
THEN
749 ELSE IF( kconds( jtype ).EQ.2 )
THEN
755 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
756 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
757 $ a, lda, work( 2*n+1 ), iinfo )
759 ELSE IF( itype.EQ.7 )
THEN
763 CALL zlatmr( n, n,
'D', iseed,
'S', work, 6, one, cone,
764 $
'T',
'N', work( n+1 ), 1, one,
765 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
766 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
768 ELSE IF( itype.EQ.8 )
THEN
772 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
773 $
'T',
'N', work( n+1 ), 1, one,
774 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
775 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
777 ELSE IF( itype.EQ.9 )
THEN
781 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
782 $
'T',
'N', work( n+1 ), 1, one,
783 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
784 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
786 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
787 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
789 CALL zlaset(
'Full', n-3, 2, czero, czero,
791 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
795 ELSE IF( itype.EQ.10 )
THEN
799 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
800 $
'T',
'N', work( n+1 ), 1, one,
801 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
802 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
809 IF( iinfo.NE.0 )
THEN
810 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
823 ELSE IF( iwk.EQ.2 )
THEN
826 nnwork = 6*n + 2*n**2
828 nnwork = max( nnwork, 1 )
837 CALL zget23( .false., 0, balanc, jtype, thresh,
838 $ ioldsd, nounit, n, a, lda, h, w, w1, vl,
839 $ ldvl, vr, ldvr, lre, ldlre, rcondv,
840 $ rcndv1, rcdvin, rconde, rcnde1, rcdein,
841 $ scale, scale1, result, work, nnwork,
849 IF( result( j ).GE.zero )
851 IF( result( j ).GE.thresh )
856 $ ntestf = ntestf + 1
857 IF( ntestf.EQ.1 )
THEN
858 WRITE( nounit, fmt = 9999 )path
859 WRITE( nounit, fmt = 9998 )
860 WRITE( nounit, fmt = 9997 )
861 WRITE( nounit, fmt = 9996 )
862 WRITE( nounit, fmt = 9995 )thresh
867 IF( result( j ).GE.thresh )
THEN
868 WRITE( nounit, fmt = 9994 )balanc, n, iwk,
869 $ ioldsd, jtype, j, result( j )
873 nerrs = nerrs + nfail
874 ntestt = ntestt + ntest
889 READ( niunit, fmt = *, end = 220 )n, isrt
898 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
901 READ( niunit, fmt = * )wr, wi, rcdein( i ), rcdvin( i )
902 w1( i ) = dcmplx( wr, wi )
904 CALL zget23( .true., isrt,
'N', 22, thresh, iseed, nounit, n, a,
905 $ lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre,
906 $ rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein,
907 $ scale, scale1, result, work, 6*n+2*n**2, rwork,
915 IF( result( j ).GE.zero )
917 IF( result( j ).GE.thresh )
922 $ ntestf = ntestf + 1
923 IF( ntestf.EQ.1 )
THEN
924 WRITE( nounit, fmt = 9999 )path
925 WRITE( nounit, fmt = 9998 )
926 WRITE( nounit, fmt = 9997 )
927 WRITE( nounit, fmt = 9996 )
928 WRITE( nounit, fmt = 9995 )thresh
933 IF( result( j ).GE.thresh )
THEN
934 WRITE( nounit, fmt = 9993 )n, jtype, j, result( j )
938 nerrs = nerrs + nfail
939 ntestt = ntestt + ntest
945 CALL dlasum( path, nounit, nerrs, ntestt )
947 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
948 $
'Decomposition Expert Driver',
949 $ /
' Matrix types (see ZDRVVX for details): ' )
951 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
952 $
' ',
' 5=Diagonal: geometr. spaced entries.',
953 $ /
' 2=Identity matrix. ',
' 6=Diagona',
954 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
955 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
956 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
957 $
'mall, evenly spaced.' )
958 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
959 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
960 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
961 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
962 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
963 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
964 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
965 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
967 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
968 $
'with small random entries.', /
' 20=Matrix with large ran',
969 $
'dom entries. ',
' 22=Matrix read from input file', / )
970 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
971 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
972 $ /
' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
973 $ /
' 3 = | |VR(i)| - 1 | / ulp ',
974 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
975 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
976 $
' 1/ulp otherwise', /
977 $
' 6 = 0 if VR same no matter what else computed,',
978 $
' 1/ulp otherwise', /
979 $
' 7 = 0 if VL same no matter what else computed,',
980 $
' 1/ulp otherwise', /
981 $
' 8 = 0 if RCONDV same no matter what else computed,',
982 $
' 1/ulp otherwise', /
983 $
' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
984 $
' computed, 1/ulp otherwise',
985 $ /
' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
986 $ /
' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
987 9994
FORMAT(
' BALANC=''', a1,
''',N=', i4,
',IWK=', i1,
', seed=',
988 $ 4( i4,
',' ),
' type ', i2,
', test(', i2,
')=', g10.3 )
989 9993
FORMAT(
' N=', i5,
', input example =', i3,
', test(', i2,
')=',
991 9992
FORMAT(
' ZDRVVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
992 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine zlatmr(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)
ZLATMR
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
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine zlatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
ZLATME
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
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