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
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
',
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, ')
' )