387 SUBROUTINE cdrvev( 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,
403 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
404 REAL RESULT( 7 ), RWORK( * )
405 COMPLEX A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
406 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
414 PARAMETER ( CZERO = ( 0.0e+0, 0.0e+0 ) )
416 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
418 parameter( zero = 0.0e+0, one = 1.0e+0 )
420 parameter( two = 2.0e+0 )
422 parameter( maxtyp = 21 )
427 INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
428 $ jtype, mtypes, n, nerrs, nfail, nmax,
429 $ nnwork, ntest, ntestf, ntestt
430 REAL 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 ),
442 EXTERNAL SCNRM2, SLAMCH
449 INTRINSIC abs, aimag, cmplx, max, min, real, 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 ) =
'Complex 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(
'CDRVEV', -info )
511 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
516 unfl = slamch(
'Safe minimum' )
518 ulp = slamch(
'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 claset(
'Full', lda, n, czero, czero, a, lda )
593 IF( itype.EQ.1 )
THEN
596 ELSE IF( itype.EQ.2 )
THEN
601 a( jcol, jcol ) = cmplx( anorm )
604 ELSE IF( itype.EQ.3 )
THEN
609 a( jcol, jcol ) = cmplx( anorm )
611 $ a( jcol, jcol-1 ) = cone
614 ELSE IF( itype.EQ.4 )
THEN
618 CALL clatms( 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 clatms( 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 clatme( n,
'D', iseed, work, imode, cond, cone,
643 $
'T',
'T',
'T', rwork, 4, conds, n, n,
644 $ anorm, a, lda, work( 2*n+1 ), iinfo )
646 ELSE IF( itype.EQ.7 )
THEN
650 CALL clatmr( 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 clatmr( 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 clatmr( 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 claset(
'Full', 2, n, czero, czero, a, lda )
674 CALL claset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
676 CALL claset(
'Full', n-3, 2, czero, czero,
678 CALL claset(
'Full', 1, n, czero, czero, a( n, 1 ),
682 ELSE IF( itype.EQ.10 )
THEN
686 CALL clatmr( 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 clacpy(
'F', n, n, a, lda, h, lda )
724 CALL cgeev(
'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 )
'CGEEV1', iinfo, n, jtype,
736 CALL cget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work,
738 result( 1 ) = res( 1 )
742 CALL cget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work,
744 result( 2 ) = res( 1 )
749 tnrm = scnrm2( 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( aimag( vr( jj, j ) ).EQ.zero .AND.
759 $ abs( real( vr( jj, j ) ) ).GT.vrmx )
760 $ vrmx = abs( real( vr( jj, j ) ) )
762 IF( vrmx / vmx.LT.one-two*ulp )
763 $ result( 3 ) = ulpinv
769 tnrm = scnrm2( 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( aimag( vl( jj, j ) ).EQ.zero .AND.
779 $ abs( real( vl( jj, j ) ) ).GT.vrmx )
780 $ vrmx = abs( real( vl( jj, j ) ) )
782 IF( vrmx / vmx.LT.one-two*ulp )
783 $ result( 4 ) = ulpinv
788 CALL clacpy(
'F', n, n, a, lda, h, lda )
789 CALL cgeev(
'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 )
'CGEEV2', iinfo, n, jtype,
802 IF( w( j ).NE.w1( j ) )
803 $ result( 5 ) = ulpinv
808 CALL clacpy(
'F', n, n, a, lda, h, lda )
809 CALL cgeev(
'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 )
'CGEEV3', 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 clacpy(
'F', n, n, a, lda, h, lda )
838 CALL cgeev(
'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 )
'CGEEV4', 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 slasum( path, nounit, nerrs, ntestt )
906 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
907 $
'Decomposition Driver', /
908 $
' Matrix types (see CDRVEV 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(
' CDRVEV: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
943 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine xerbla(srname, info)
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 cget22(transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
CGET22
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 clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
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 clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
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 slasum(type, iounit, ie, nrun)
SLASUM