387 SUBROUTINE zdrvev( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
388 $ NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR,
389 $ LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK,
397 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES,
399 DOUBLE PRECISION THRESH
403 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
404 DOUBLE PRECISION RESULT( 7 ), RWORK( * )
405 COMPLEX*16 A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
406 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
414 PARAMETER ( CZERO = ( 0.0d+0, 0.0d+0 ) )
416 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
417 DOUBLE PRECISION ZERO, ONE
418 parameter( zero = 0.0d+0, one = 1.0d+0 )
420 parameter( two = 2.0d+0 )
422 parameter( maxtyp = 21 )
427 INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
428 $ jtype, mtypes, n, nerrs, nfail, nmax, nnwork,
429 $ ntest, ntestf, ntestt
430 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM,
431 $ ULP, ULPINV, UNFL, VMX, VRMX, VTST
434 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
435 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
437 DOUBLE PRECISION RES( 2 )
441 DOUBLE PRECISION DLAMCH, DZNRM2
442 EXTERNAL DLAMCH, DZNRM2
449 INTRINSIC abs, dble, dcmplx, dimag, max, min, sqrt
452 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
453 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
455 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
456 $ 1, 5, 5, 5, 4, 3, 1 /
457 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
461 path( 1: 1 ) =
'Zomplex precision'
475 nmax = max( nmax, nn( j ) )
482 IF( nsizes.LT.0 )
THEN
484 ELSE IF( badnn )
THEN
486 ELSE IF( ntypes.LT.0 )
THEN
488 ELSE IF( thresh.LT.zero )
THEN
490 ELSE IF( nounit.LE.0 )
THEN
492 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
494 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
496 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
498 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
500 ELSE IF( 5*nmax+2*nmax**2.GT.nwork )
THEN
505 CALL xerbla(
'ZDRVEV', -info )
511 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
516 unfl = dlamch(
'Safe minimum' )
518 ulp = dlamch(
'Precision' )
527 DO 270 jsize = 1, nsizes
529 IF( nsizes.NE.1 )
THEN
530 mtypes = min( maxtyp, ntypes )
532 mtypes = min( maxtyp+1, ntypes )
535 DO 260 jtype = 1, mtypes
536 IF( .NOT.dotype( jtype ) )
542 ioldsd( j ) = iseed( j )
561 IF( mtypes.GT.maxtyp )
564 itype = ktype( jtype )
565 imode = kmode( jtype )
569 GO TO ( 30, 40, 50 )kmagn( jtype )
585 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
593 IF( itype.EQ.1 )
THEN
596 ELSE IF( itype.EQ.2 )
THEN
601 a( jcol, jcol ) = dcmplx( anorm )
604 ELSE IF( itype.EQ.3 )
THEN
609 a( jcol, jcol ) = dcmplx( anorm )
611 $ a( jcol, jcol-1 ) = cone
614 ELSE IF( itype.EQ.4 )
THEN
618 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
619 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
622 ELSE IF( itype.EQ.5 )
THEN
626 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
627 $ anorm, n, n,
'N', a, lda, work( n+1 ),
630 ELSE IF( itype.EQ.6 )
THEN
634 IF( kconds( jtype ).EQ.1 )
THEN
636 ELSE IF( kconds( jtype ).EQ.2 )
THEN
642 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
643 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
644 $ a, lda, work( 2*n+1 ), iinfo )
646 ELSE IF( itype.EQ.7 )
THEN
650 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
651 $
'T',
'N', work( n+1 ), 1, one,
652 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
653 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
655 ELSE IF( itype.EQ.8 )
THEN
659 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
660 $
'T',
'N', work( n+1 ), 1, one,
661 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
662 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
664 ELSE IF( itype.EQ.9 )
THEN
668 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
669 $
'T',
'N', work( n+1 ), 1, one,
670 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
671 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
673 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
674 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
676 CALL zlaset(
'Full', n-3, 2, czero, czero,
678 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
682 ELSE IF( itype.EQ.10 )
THEN
686 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
687 $
'T',
'N', work( n+1 ), 1, one,
688 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
689 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
696 IF( iinfo.NE.0 )
THEN
697 WRITE( nounit, fmt = 9993 )
'Generator', iinfo, n, jtype,
711 nnwork = 5*n + 2*n**2
713 nnwork = max( nnwork, 1 )
723 CALL zlacpy(
'F', n, n, a, lda, h, lda )
724 CALL zgeev(
'V',
'V', n, h, lda, w, vl, ldvl, vr, ldvr,
725 $ work, nnwork, rwork, iinfo )
726 IF( iinfo.NE.0 )
THEN
728 WRITE( nounit, fmt = 9993 )
'ZGEEV1', iinfo, n, jtype,
736 CALL zget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work,
738 result( 1 ) = res( 1 )
742 CALL zget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work,
744 result( 2 ) = res( 1 )
749 tnrm = dznrm2( n, vr( 1, j ), 1 )
750 result( 3 ) = max( result( 3 ),
751 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
755 vtst = abs( vr( jj, j ) )
758 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
759 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
760 $ vrmx = abs( dble( vr( jj, j ) ) )
762 IF( vrmx / vmx.LT.one-two*ulp )
763 $ result( 3 ) = ulpinv
769 tnrm = dznrm2( n, vl( 1, j ), 1 )
770 result( 4 ) = max( result( 4 ),
771 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
775 vtst = abs( vl( jj, j ) )
778 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
779 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
780 $ vrmx = abs( dble( vl( jj, j ) ) )
782 IF( vrmx / vmx.LT.one-two*ulp )
783 $ result( 4 ) = ulpinv
788 CALL zlacpy(
'F', n, n, a, lda, h, lda )
789 CALL zgeev(
'N',
'N', n, h, lda, w1, dum, 1, dum, 1,
790 $ work, nnwork, rwork, iinfo )
791 IF( iinfo.NE.0 )
THEN
793 WRITE( nounit, fmt = 9993 )
'ZGEEV2', iinfo, n, jtype,
802 IF( w( j ).NE.w1( j ) )
803 $ result( 5 ) = ulpinv
808 CALL zlacpy(
'F', n, n, a, lda, h, lda )
809 CALL zgeev(
'N',
'V', n, h, lda, w1, dum, 1, lre, ldlre,
810 $ work, nnwork, rwork, iinfo )
811 IF( iinfo.NE.0 )
THEN
813 WRITE( nounit, fmt = 9993 )
'ZGEEV3', iinfo, n, jtype,
822 IF( w( j ).NE.w1( j ) )
823 $ result( 5 ) = ulpinv
830 IF( vr( j, jj ).NE.lre( j, jj ) )
831 $ result( 6 ) = ulpinv
837 CALL zlacpy(
'F', n, n, a, lda, h, lda )
838 CALL zgeev(
'V',
'N', n, h, lda, w1, lre, ldlre, dum, 1,
839 $ work, nnwork, rwork, iinfo )
840 IF( iinfo.NE.0 )
THEN
842 WRITE( nounit, fmt = 9993 )
'ZGEEV4', iinfo, n, jtype,
851 IF( w( j ).NE.w1( j ) )
852 $ result( 5 ) = ulpinv
859 IF( vl( j, jj ).NE.lre( j, jj ) )
860 $ result( 7 ) = ulpinv
871 IF( result( j ).GE.zero )
873 IF( result( j ).GE.thresh )
878 $ ntestf = ntestf + 1
879 IF( ntestf.EQ.1 )
THEN
880 WRITE( nounit, fmt = 9999 )path
881 WRITE( nounit, fmt = 9998 )
882 WRITE( nounit, fmt = 9997 )
883 WRITE( nounit, fmt = 9996 )
884 WRITE( nounit, fmt = 9995 )thresh
889 IF( result( j ).GE.thresh )
THEN
890 WRITE( nounit, fmt = 9994 )n, iwk, ioldsd, jtype,
895 nerrs = nerrs + nfail
896 ntestt = ntestt + ntest
904 CALL dlasum( path, nounit, nerrs, ntestt )
906 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
907 $
'Decomposition Driver', /
908 $
' Matrix types (see ZDRVEV for details): ' )
910 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
911 $
' ',
' 5=Diagonal: geometr. spaced entries.',
912 $ /
' 2=Identity matrix. ',
' 6=Diagona',
913 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
914 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
915 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
916 $
'mall, evenly spaced.' )
917 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
918 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
919 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
920 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
921 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
922 $
'lex ', a6, /
' 12=Well-cond., random complex ', a6,
' ',
923 $
' 17=Ill-cond., large rand. complx ', a4, /
' 13=Ill-condi',
924 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
926 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
927 $
'with small random entries.', /
' 20=Matrix with large ran',
928 $
'dom entries. ', / )
929 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
930 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
931 $ /
' 2 = | conj-trans(A) VL - VL conj-trans(W) | /',
932 $
' ( n |A| ulp ) ', /
' 3 = | |VR(i)| - 1 | / ulp ',
933 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
934 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
935 $
' 1/ulp otherwise', /
936 $
' 6 = 0 if VR same no matter if VL computed,',
937 $
' 1/ulp otherwise', /
938 $
' 7 = 0 if VL same no matter if VR computed,',
939 $
' 1/ulp otherwise', / )
940 9994
FORMAT(
' N=', i5,
', IWK=', i2,
', seed=', 4( i4,
',' ),
941 $
' type ', i2,
', test(', i2,
')=', g10.3 )
942 9993
FORMAT(
' ZDRVEV: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
943 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine xerbla(srname, info)
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
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
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 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
subroutine zlatme(n, dist, iseed, d, mode, cond, dmax, rsign, upper, sim, ds, modes, conds, kl, ku, anorm, a, lda, work, info)
ZLATME
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 zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS