389 SUBROUTINE cdrvev( 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,
406 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
407 REAL RESULT( 7 ), RWORK( * )
408 COMPLEX A( lda, * ), H( lda, * ), LRE( ldlre, * ),
409 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
417 parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
419 parameter ( cone = ( 1.0e+0, 0.0e+0 ) )
421 parameter ( zero = 0.0e+0, one = 1.0e+0 )
423 parameter ( two = 2.0e+0 )
425 parameter ( maxtyp = 21 )
430 INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
431 $ jtype, mtypes, n, nerrs, nfail, nmax,
432 $ nnwork, ntest, ntestf, ntestt
433 REAL 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 ),
445 EXTERNAL scnrm2, slamch
452 INTRINSIC abs, aimag, cmplx, max, min,
REAL, 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 ) =
'Complex 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(
'CDRVEV', -info )
514 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
519 unfl = slamch(
'Safe minimum' )
522 ulp = slamch(
'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 claset(
'Full', lda, n, czero, czero, a, lda )
597 IF( itype.EQ.1 )
THEN
600 ELSE IF( itype.EQ.2 )
THEN
605 a( jcol, jcol ) = cmplx( anorm )
608 ELSE IF( itype.EQ.3 )
THEN
613 a( jcol, jcol ) = cmplx( anorm )
615 $ a( jcol, jcol-1 ) = cone
618 ELSE IF( itype.EQ.4 )
THEN
622 CALL clatms( 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 clatms( 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 clatme( n,
'D', iseed, work, imode, cond, cone,
647 $
'T',
'T',
'T', rwork, 4, conds, n, n,
648 $ anorm, a, lda, work( 2*n+1 ), iinfo )
650 ELSE IF( itype.EQ.7 )
THEN
654 CALL clatmr( 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 clatmr( 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 clatmr( 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 claset(
'Full', 2, n, czero, czero, a, lda )
678 CALL claset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
680 CALL claset(
'Full', n-3, 2, czero, czero,
682 CALL claset(
'Full', 1, n, czero, czero, a( n, 1 ),
686 ELSE IF( itype.EQ.10 )
THEN
690 CALL clatmr( 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 clacpy(
'F', n, n, a, lda, h, lda )
728 CALL cgeev(
'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 )
'CGEEV1', iinfo, n, jtype,
740 CALL cget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work,
742 result( 1 ) = res( 1 )
746 CALL cget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work,
748 result( 2 ) = res( 1 )
753 tnrm = scnrm2( 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( aimag( vr( jj, j ) ).EQ.zero .AND.
763 $ abs(
REAL( VR( JJ, J ) ) ).GT.vrmx )
764 $ vrmx = abs(
REAL( VR( JJ, J ) ) )
766 IF( vrmx / vmx.LT.one-two*ulp )
767 $ result( 3 ) = ulpinv
773 tnrm = scnrm2( 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( aimag( vl( jj, j ) ).EQ.zero .AND.
783 $ abs(
REAL( VL( JJ, J ) ) ).GT.vrmx )
784 $ vrmx = abs(
REAL( VL( JJ, J ) ) )
786 IF( vrmx / vmx.LT.one-two*ulp )
787 $ result( 4 ) = ulpinv
792 CALL clacpy(
'F', n, n, a, lda, h, lda )
793 CALL cgeev(
'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 )
'CGEEV2', iinfo, n, jtype,
806 IF( w( j ).NE.w1( j ) )
807 $ result( 5 ) = ulpinv
812 CALL clacpy(
'F', n, n, a, lda, h, lda )
813 CALL cgeev(
'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 )
'CGEEV3', 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 clacpy(
'F', n, n, a, lda, h, lda )
842 CALL cgeev(
'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 )
'CGEEV4', 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 slasum( path, nounit, nerrs, ntestt )
910 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
911 $
'Decomposition Driver', /
912 $
' Matrix types (see CDRVEV 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(
' CDRVEV: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
947 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine clatmr(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)
CLATMR
subroutine cgeev(JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
CGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine clatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
CLATME
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine cget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
CGET22
subroutine cdrvev(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK, INFO)
CDRVEV
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM