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' )
519 ulp = dlamch(
'Precision' )
528 DO 270 jsize = 1, nsizes
530 IF( nsizes.NE.1 )
THEN
531 mtypes = min( maxtyp, ntypes )
533 mtypes = min( maxtyp+1, ntypes )
536 DO 260 jtype = 1, mtypes
537 IF( .NOT.dotype( jtype ) )
543 ioldsd( j ) = iseed( j )
562 IF( mtypes.GT.maxtyp )
565 itype = ktype( jtype )
566 imode = kmode( jtype )
570 GO TO ( 30, 40, 50 )kmagn( jtype )
586 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
594 IF( itype.EQ.1 )
THEN
597 ELSE IF( itype.EQ.2 )
THEN
602 a( jcol, jcol ) = dcmplx( anorm )
605 ELSE IF( itype.EQ.3 )
THEN
610 a( jcol, jcol ) = dcmplx( anorm )
612 $ a( jcol, jcol-1 ) = cone
615 ELSE IF( itype.EQ.4 )
THEN
619 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
620 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
623 ELSE IF( itype.EQ.5 )
THEN
627 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
628 $ anorm, n, n,
'N', a, lda, work( n+1 ),
631 ELSE IF( itype.EQ.6 )
THEN
635 IF( kconds( jtype ).EQ.1 )
THEN
637 ELSE IF( kconds( jtype ).EQ.2 )
THEN
643 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
644 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
645 $ a, lda, work( 2*n+1 ), iinfo )
647 ELSE IF( itype.EQ.7 )
THEN
651 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
652 $
'T',
'N', work( n+1 ), 1, one,
653 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
654 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
656 ELSE IF( itype.EQ.8 )
THEN
660 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
661 $
'T',
'N', work( n+1 ), 1, one,
662 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
663 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
665 ELSE IF( itype.EQ.9 )
THEN
669 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
670 $
'T',
'N', work( n+1 ), 1, one,
671 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
672 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
674 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
675 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
677 CALL zlaset(
'Full', n-3, 2, czero, czero,
679 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
683 ELSE IF( itype.EQ.10 )
THEN
687 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
688 $
'T',
'N', work( n+1 ), 1, one,
689 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
690 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
697 IF( iinfo.NE.0 )
THEN
698 WRITE( nounit, fmt = 9993 )
'Generator', iinfo, n, jtype,
712 nnwork = 5*n + 2*n**2
714 nnwork = max( nnwork, 1 )
724 CALL zlacpy(
'F', n, n, a, lda, h, lda )
725 CALL zgeev(
'V',
'V', n, h, lda, w, vl, ldvl, vr, ldvr,
726 $ work, nnwork, rwork, iinfo )
727 IF( iinfo.NE.0 )
THEN
729 WRITE( nounit, fmt = 9993 )
'ZGEEV1', iinfo, n, jtype,
737 CALL zget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work,
739 result( 1 ) = res( 1 )
743 CALL zget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work,
745 result( 2 ) = res( 1 )
750 tnrm = dznrm2( n, vr( 1, j ), 1 )
751 result( 3 ) = max( result( 3 ),
752 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
756 vtst = abs( vr( jj, j ) )
759 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
760 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
761 $ vrmx = abs( dble( vr( jj, j ) ) )
763 IF( vrmx / vmx.LT.one-two*ulp )
764 $ result( 3 ) = ulpinv
770 tnrm = dznrm2( n, vl( 1, j ), 1 )
771 result( 4 ) = max( result( 4 ),
772 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
776 vtst = abs( vl( jj, j ) )
779 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
780 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
781 $ vrmx = abs( dble( vl( jj, j ) ) )
783 IF( vrmx / vmx.LT.one-two*ulp )
784 $ result( 4 ) = ulpinv
789 CALL zlacpy(
'F', n, n, a, lda, h, lda )
790 CALL zgeev(
'N',
'N', n, h, lda, w1, dum, 1, dum, 1,
791 $ work, nnwork, rwork, iinfo )
792 IF( iinfo.NE.0 )
THEN
794 WRITE( nounit, fmt = 9993 )
'ZGEEV2', iinfo, n, jtype,
803 IF( w( j ).NE.w1( j ) )
804 $ result( 5 ) = ulpinv
809 CALL zlacpy(
'F', n, n, a, lda, h, lda )
810 CALL zgeev(
'N',
'V', n, h, lda, w1, dum, 1, lre, ldlre,
811 $ work, nnwork, rwork, iinfo )
812 IF( iinfo.NE.0 )
THEN
814 WRITE( nounit, fmt = 9993 )
'ZGEEV3', iinfo, n, jtype,
823 IF( w( j ).NE.w1( j ) )
824 $ result( 5 ) = ulpinv
831 IF( vr( j, jj ).NE.lre( j, jj ) )
832 $ result( 6 ) = ulpinv
838 CALL zlacpy(
'F', n, n, a, lda, h, lda )
839 CALL zgeev(
'V',
'N', n, h, lda, w1, lre, ldlre, dum, 1,
840 $ work, nnwork, rwork, iinfo )
841 IF( iinfo.NE.0 )
THEN
843 WRITE( nounit, fmt = 9993 )
'ZGEEV4', iinfo, n, jtype,
852 IF( w( j ).NE.w1( j ) )
853 $ result( 5 ) = ulpinv
860 IF( vl( j, jj ).NE.lre( j, jj ) )
861 $ result( 7 ) = ulpinv
872 IF( result( j ).GE.zero )
874 IF( result( j ).GE.thresh )
879 $ ntestf = ntestf + 1
880 IF( ntestf.EQ.1 )
THEN
881 WRITE( nounit, fmt = 9999 )path
882 WRITE( nounit, fmt = 9998 )
883 WRITE( nounit, fmt = 9997 )
884 WRITE( nounit, fmt = 9996 )
885 WRITE( nounit, fmt = 9995 )thresh
890 IF( result( j ).GE.thresh )
THEN
891 WRITE( nounit, fmt = 9994 )n, iwk, ioldsd, jtype,
896 nerrs = nerrs + nfail
897 ntestt = ntestt + ntest
905 CALL dlasum( path, nounit, nerrs, ntestt )
907 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
908 $
'Decomposition Driver', /
909 $
' Matrix types (see ZDRVEV for details): ' )
911 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
912 $
' ',
' 5=Diagonal: geometr. spaced entries.',
913 $ /
' 2=Identity matrix. ',
' 6=Diagona',
914 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
915 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
916 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
917 $
'mall, evenly spaced.' )
918 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
919 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
920 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
921 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
922 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
923 $
'lex ', a6, /
' 12=Well-cond., random complex ', a6,
' ',
924 $
' 17=Ill-cond., large rand. complx ', a4, /
' 13=Ill-condi',
925 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
927 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
928 $
'with small random entries.', /
' 20=Matrix with large ran',
929 $
'dom entries. ', / )
930 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
931 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
932 $ /
' 2 = | conj-trans(A) VL - VL conj-trans(W) | /',
933 $
' ( n |A| ulp ) ', /
' 3 = | |VR(i)| - 1 | / ulp ',
934 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
935 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
936 $
' 1/ulp otherwise', /
937 $
' 6 = 0 if VR same no matter if VL computed,',
938 $
' 1/ulp otherwise', /
939 $
' 7 = 0 if VL same no matter if VR computed,',
940 $
' 1/ulp otherwise', / )
941 9994
FORMAT(
' N=', i5,
', IWK=', i2,
', seed=', 4( i4,
',' ),
942 $
' type ', i2,
', test(', i2,
')=', g10.3 )
943 9993
FORMAT(
' ZDRVEV: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
944 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine xerbla(SRNAME, INFO)
XERBLA
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 zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
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 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 dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM