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 ),
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( / 1
x, 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,
'.', / 9
x,
'N=',
947 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
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 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
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
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 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 ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
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
REAL function scnrm2(N, X, INCX)
SCNRM2