389 SUBROUTINE zdrvev( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
390 $ NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR,
391 $ LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK,
400 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES,
402 DOUBLE PRECISION THRESH
406 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
407 DOUBLE PRECISION RESULT( 7 ), RWORK( * )
408 COMPLEX*16 A( lda, * ), H( lda, * ), LRE( ldlre, * ),
409 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
417 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
419 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
420 DOUBLE PRECISION ZERO, ONE
421 parameter( zero = 0.0d+0, one = 1.0d+0 )
423 parameter( two = 2.0d+0 )
425 parameter( maxtyp = 21 )
430 INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
431 $ jtype, mtypes, n, nerrs, nfail, nmax, nnwork,
432 $ ntest, ntestf, ntestt
433 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM,
434 $ ulp, ulpinv, unfl, vmx, vrmx, vtst
437 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
438 $ kmagn( maxtyp ), kmode( maxtyp ),
440 DOUBLE PRECISION RES( 2 )
444 DOUBLE PRECISION DLAMCH, DZNRM2
445 EXTERNAL dlamch, dznrm2
452 INTRINSIC abs, dble, dcmplx, dimag, max, min, sqrt
455 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
456 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
458 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
459 $ 1, 5, 5, 5, 4, 3, 1 /
460 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
464 path( 1: 1 ) =
'Zomplex precision' 478 nmax = max( nmax, nn( j ) )
485 IF( nsizes.LT.0 )
THEN 487 ELSE IF( badnn )
THEN 489 ELSE IF( ntypes.LT.0 )
THEN 491 ELSE IF( thresh.LT.zero )
THEN 493 ELSE IF( nounit.LE.0 )
THEN 495 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN 497 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN 499 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN 501 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN 503 ELSE IF( 5*nmax+2*nmax**2.GT.nwork )
THEN 508 CALL xerbla(
'ZDRVEV', -info )
514 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
519 unfl = dlamch(
'Safe minimum' )
522 ulp = dlamch(
'Precision' )
531 DO 270 jsize = 1, nsizes
533 IF( nsizes.NE.1 )
THEN 534 mtypes = min( maxtyp, ntypes )
536 mtypes = min( maxtyp+1, ntypes )
539 DO 260 jtype = 1, mtypes
540 IF( .NOT.dotype( jtype ) )
546 ioldsd( j ) = iseed( j )
565 IF( mtypes.GT.maxtyp )
568 itype = ktype( jtype )
569 imode = kmode( jtype )
573 GO TO ( 30, 40, 50 )kmagn( jtype )
589 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
597 IF( itype.EQ.1 )
THEN 600 ELSE IF( itype.EQ.2 )
THEN 605 a( jcol, jcol ) = dcmplx( anorm )
608 ELSE IF( itype.EQ.3 )
THEN 613 a( jcol, jcol ) = dcmplx( anorm )
615 $ a( jcol, jcol-1 ) = cone
618 ELSE IF( itype.EQ.4 )
THEN 622 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
623 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
626 ELSE IF( itype.EQ.5 )
THEN 630 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
631 $ anorm, n, n,
'N', a, lda, work( n+1 ),
634 ELSE IF( itype.EQ.6 )
THEN 638 IF( kconds( jtype ).EQ.1 )
THEN 640 ELSE IF( kconds( jtype ).EQ.2 )
THEN 646 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
647 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
648 $ a, lda, work( 2*n+1 ), iinfo )
650 ELSE IF( itype.EQ.7 )
THEN 654 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
655 $
'T',
'N', work( n+1 ), 1, one,
656 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
657 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
659 ELSE IF( itype.EQ.8 )
THEN 663 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
664 $
'T',
'N', work( n+1 ), 1, one,
665 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
666 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
668 ELSE IF( itype.EQ.9 )
THEN 672 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
673 $
'T',
'N', work( n+1 ), 1, one,
674 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
675 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
677 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
678 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
680 CALL zlaset(
'Full', n-3, 2, czero, czero,
682 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
686 ELSE IF( itype.EQ.10 )
THEN 690 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
691 $
'T',
'N', work( n+1 ), 1, one,
692 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
693 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
700 IF( iinfo.NE.0 )
THEN 701 WRITE( nounit, fmt = 9993 )
'Generator', iinfo, n, jtype,
715 nnwork = 5*n + 2*n**2
717 nnwork = max( nnwork, 1 )
727 CALL zlacpy(
'F', n, n, a, lda, h, lda )
728 CALL zgeev(
'V',
'V', n, h, lda, w, vl, ldvl, vr, ldvr,
729 $ work, nnwork, rwork, iinfo )
730 IF( iinfo.NE.0 )
THEN 732 WRITE( nounit, fmt = 9993 )
'ZGEEV1', iinfo, n, jtype,
740 CALL zget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work,
742 result( 1 ) = res( 1 )
746 CALL zget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work,
748 result( 2 ) = res( 1 )
753 tnrm = dznrm2( n, vr( 1, j ), 1 )
754 result( 3 ) = max( result( 3 ),
755 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
759 vtst = abs( vr( jj, j ) )
762 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
763 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
764 $ vrmx = abs( dble( vr( jj, j ) ) )
766 IF( vrmx / vmx.LT.one-two*ulp )
767 $ result( 3 ) = ulpinv
773 tnrm = dznrm2( n, vl( 1, j ), 1 )
774 result( 4 ) = max( result( 4 ),
775 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
779 vtst = abs( vl( jj, j ) )
782 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
783 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
784 $ vrmx = abs( dble( vl( jj, j ) ) )
786 IF( vrmx / vmx.LT.one-two*ulp )
787 $ result( 4 ) = ulpinv
792 CALL zlacpy(
'F', n, n, a, lda, h, lda )
793 CALL zgeev(
'N',
'N', n, h, lda, w1, dum, 1, dum, 1,
794 $ work, nnwork, rwork, iinfo )
795 IF( iinfo.NE.0 )
THEN 797 WRITE( nounit, fmt = 9993 )
'ZGEEV2', iinfo, n, jtype,
806 IF( w( j ).NE.w1( j ) )
807 $ result( 5 ) = ulpinv
812 CALL zlacpy(
'F', n, n, a, lda, h, lda )
813 CALL zgeev(
'N',
'V', n, h, lda, w1, dum, 1, lre, ldlre,
814 $ work, nnwork, rwork, iinfo )
815 IF( iinfo.NE.0 )
THEN 817 WRITE( nounit, fmt = 9993 )
'ZGEEV3', iinfo, n, jtype,
826 IF( w( j ).NE.w1( j ) )
827 $ result( 5 ) = ulpinv
834 IF( vr( j, jj ).NE.lre( j, jj ) )
835 $ result( 6 ) = ulpinv
841 CALL zlacpy(
'F', n, n, a, lda, h, lda )
842 CALL zgeev(
'V',
'N', n, h, lda, w1, lre, ldlre, dum, 1,
843 $ work, nnwork, rwork, iinfo )
844 IF( iinfo.NE.0 )
THEN 846 WRITE( nounit, fmt = 9993 )
'ZGEEV4', iinfo, n, jtype,
855 IF( w( j ).NE.w1( j ) )
856 $ result( 5 ) = ulpinv
863 IF( vl( j, jj ).NE.lre( j, jj ) )
864 $ result( 7 ) = ulpinv
875 IF( result( j ).GE.zero )
877 IF( result( j ).GE.thresh )
882 $ ntestf = ntestf + 1
883 IF( ntestf.EQ.1 )
THEN 884 WRITE( nounit, fmt = 9999 )path
885 WRITE( nounit, fmt = 9998 )
886 WRITE( nounit, fmt = 9997 )
887 WRITE( nounit, fmt = 9996 )
888 WRITE( nounit, fmt = 9995 )thresh
893 IF( result( j ).GE.thresh )
THEN 894 WRITE( nounit, fmt = 9994 )n, iwk, ioldsd, jtype,
899 nerrs = nerrs + nfail
900 ntestt = ntestt + ntest
908 CALL dlasum( path, nounit, nerrs, ntestt )
910 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
911 $
'Decomposition Driver', /
912 $
' Matrix types (see ZDRVEV for details): ' )
914 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
915 $
' ',
' 5=Diagonal: geometr. spaced entries.',
916 $ /
' 2=Identity matrix. ',
' 6=Diagona',
917 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
918 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
919 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
920 $
'mall, evenly spaced.' )
921 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
922 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
923 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
924 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
925 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
926 $
'lex ', a6, /
' 12=Well-cond., random complex ', a6,
' ',
927 $
' 17=Ill-cond., large rand. complx ', a4, /
' 13=Ill-condi',
928 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
930 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
931 $
'with small random entries.', /
' 20=Matrix with large ran',
932 $
'dom entries. ', / )
933 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
934 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
935 $ /
' 2 = | conj-trans(A) VL - VL conj-trans(W) | /',
936 $
' ( n |A| ulp ) ', /
' 3 = | |VR(i)| - 1 | / ulp ',
937 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
938 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
939 $
' 1/ulp otherwise', /
940 $
' 6 = 0 if VR same no matter if VL computed,',
941 $
' 1/ulp otherwise', /
942 $
' 7 = 0 if VL same no matter if VR computed,',
943 $
' 1/ulp otherwise', / )
944 9994
FORMAT(
' N=', i5,
', IWK=', i2,
', seed=', 4( i4,
',' ),
945 $
' type ', i2,
', test(', i2,
')=', g10.3 )
946 9993
FORMAT(
' ZDRVEV: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
947 $ 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 zlatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
ZLATME
subroutine zget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
ZGET22
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zdrvev(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK, INFO)
ZDRVEV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
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 zgeev(JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...