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 clatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
CLATME
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 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 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 cget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
CGET22
subroutine xerbla(SRNAME, INFO)
XERBLA
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 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 clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM