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 zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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 ...
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 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 zget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
ZGET22