493 SUBROUTINE cdrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
494 $ niunit, nounit, a, lda, h, w, w1, vl, ldvl, vr,
495 $ ldvr, lre, ldlre, rcondv, rcndv1, rcdvin,
496 $ rconde, rcnde1, rcdein, scale, scale1, result,
497 $ work, nwork, rwork, info )
505 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
506 $ nsizes, ntypes, nwork
511 INTEGER ISEED( 4 ), NN( * )
512 REAL RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
513 $ rcndv1( * ), rconde( * ), rcondv( * ),
514 $ result( 11 ), rwork( * ), scale( * ),
516 COMPLEX A( lda, * ), H( lda, * ), LRE( ldlre, * ),
517 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
525 parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
527 parameter ( cone = ( 1.0e+0, 0.0e+0 ) )
529 parameter ( zero = 0.0e+0, one = 1.0e+0 )
531 parameter ( maxtyp = 21 )
537 INTEGER I, IBAL, IINFO, IMODE, ISRT, ITYPE, IWK, J,
538 $ jcol, jsize, jtype, mtypes, n, nerrs,
539 $ nfail, nmax, nnwork, ntest, ntestf, ntestt
540 REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
541 $ ulpinv, unfl, wi, wr
545 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
546 $ kmagn( maxtyp ), kmode( maxtyp ),
558 INTRINSIC abs, cmplx, max, min, sqrt
561 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
562 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
564 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
565 $ 1, 5, 5, 5, 4, 3, 1 /
566 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
567 DATA bal /
'N',
'P',
'S',
'B' /
571 path( 1: 1 ) =
'Complex precision'
589 nmax = max( nmax, nn( j ) )
596 IF( nsizes.LT.0 )
THEN
598 ELSE IF( badnn )
THEN
600 ELSE IF( ntypes.LT.0 )
THEN
602 ELSE IF( thresh.LT.zero )
THEN
604 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
606 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
608 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
610 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
612 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
617 CALL xerbla(
'CDRVVX', -info )
623 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
628 unfl = slamch(
'Safe minimum' )
631 ulp = slamch(
'Precision' )
640 DO 150 jsize = 1, nsizes
642 IF( nsizes.NE.1 )
THEN
643 mtypes = min( maxtyp, ntypes )
645 mtypes = min( maxtyp+1, ntypes )
648 DO 140 jtype = 1, mtypes
649 IF( .NOT.dotype( jtype ) )
655 ioldsd( j ) = iseed( j )
674 IF( mtypes.GT.maxtyp )
677 itype = ktype( jtype )
678 imode = kmode( jtype )
682 GO TO ( 30, 40, 50 )kmagn( jtype )
698 CALL claset(
'Full', lda, n, czero, czero, a, lda )
706 IF( itype.EQ.1 )
THEN
709 ELSE IF( itype.EQ.2 )
THEN
714 a( jcol, jcol ) = anorm
717 ELSE IF( itype.EQ.3 )
THEN
722 a( jcol, jcol ) = anorm
724 $ a( jcol, jcol-1 ) = one
727 ELSE IF( itype.EQ.4 )
THEN
731 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
732 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
735 ELSE IF( itype.EQ.5 )
THEN
739 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
740 $ anorm, n, n,
'N', a, lda, work( n+1 ),
743 ELSE IF( itype.EQ.6 )
THEN
747 IF( kconds( jtype ).EQ.1 )
THEN
749 ELSE IF( kconds( jtype ).EQ.2 )
THEN
755 CALL clatme( n,
'D', iseed, work, imode, cond, cone,
756 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
757 $ a, lda, work( 2*n+1 ), iinfo )
759 ELSE IF( itype.EQ.7 )
THEN
763 CALL clatmr( n, n,
'D', iseed,
'S', work, 6, one, cone,
764 $
'T',
'N', work( n+1 ), 1, one,
765 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
766 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
768 ELSE IF( itype.EQ.8 )
THEN
772 CALL clatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
773 $
'T',
'N', work( n+1 ), 1, one,
774 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
775 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
777 ELSE IF( itype.EQ.9 )
THEN
781 CALL clatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
782 $
'T',
'N', work( n+1 ), 1, one,
783 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
784 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
786 CALL claset(
'Full', 2, n, czero, czero, a, lda )
787 CALL claset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
789 CALL claset(
'Full', n-3, 2, czero, czero,
791 CALL claset(
'Full', 1, n, czero, czero, a( n, 1 ),
795 ELSE IF( itype.EQ.10 )
THEN
799 CALL clatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
800 $
'T',
'N', work( n+1 ), 1, one,
801 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
802 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
809 IF( iinfo.NE.0 )
THEN
810 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
823 ELSE IF( iwk.EQ.2 )
THEN
826 nnwork = 6*n + 2*n**2
828 nnwork = max( nnwork, 1 )
837 CALL cget23( .false., 0, balanc, jtype, thresh,
838 $ ioldsd, nounit, n, a, lda, h, w, w1, vl,
839 $ ldvl, vr, ldvr, lre, ldlre, rcondv,
840 $ rcndv1, rcdvin, rconde, rcnde1, rcdein,
841 $ scale, scale1, result, work, nnwork,
849 IF( result( j ).GE.zero )
851 IF( result( j ).GE.thresh )
856 $ ntestf = ntestf + 1
857 IF( ntestf.EQ.1 )
THEN
858 WRITE( nounit, fmt = 9999 )path
859 WRITE( nounit, fmt = 9998 )
860 WRITE( nounit, fmt = 9997 )
861 WRITE( nounit, fmt = 9996 )
862 WRITE( nounit, fmt = 9995 )thresh
867 IF( result( j ).GE.thresh )
THEN
868 WRITE( nounit, fmt = 9994 )balanc, n, iwk,
869 $ ioldsd, jtype, j, result( j )
873 nerrs = nerrs + nfail
874 ntestt = ntestt + ntest
889 READ( niunit, fmt = *, end = 220 )n, isrt
898 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
901 READ( niunit, fmt = * )wr, wi, rcdein( i ), rcdvin( i )
902 w1( i ) = cmplx( wr, wi )
904 CALL cget23( .true., isrt,
'N', 22, thresh, iseed, nounit, n, a,
905 $ lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre,
906 $ rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein,
907 $ scale, scale1, result, work, 6*n+2*n**2, rwork,
915 IF( result( j ).GE.zero )
917 IF( result( j ).GE.thresh )
922 $ ntestf = ntestf + 1
923 IF( ntestf.EQ.1 )
THEN
924 WRITE( nounit, fmt = 9999 )path
925 WRITE( nounit, fmt = 9998 )
926 WRITE( nounit, fmt = 9997 )
927 WRITE( nounit, fmt = 9996 )
928 WRITE( nounit, fmt = 9995 )thresh
933 IF( result( j ).GE.thresh )
THEN
934 WRITE( nounit, fmt = 9993 )n, jtype, j, result( j )
938 nerrs = nerrs + nfail
939 ntestt = ntestt + ntest
945 CALL slasum( path, nounit, nerrs, ntestt )
947 9999
FORMAT( / 1x, a3,
' -- Complex Eigenvalue-Eigenvector ',
948 $
'Decomposition Expert Driver',
949 $ /
' Matrix types (see CDRVVX for details): ' )
951 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
952 $
' ',
' 5=Diagonal: geometr. spaced entries.',
953 $ /
' 2=Identity matrix. ',
' 6=Diagona',
954 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
955 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
956 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
957 $
'mall, evenly spaced.' )
958 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
959 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
960 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
961 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
962 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
963 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
964 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
965 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
967 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
968 $
'with small random entries.', /
' 20=Matrix with large ran',
969 $
'dom entries. ',
' 22=Matrix read from input file', / )
970 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
971 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
972 $ /
' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
973 $ /
' 3 = | |VR(i)| - 1 | / ulp ',
974 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
975 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
976 $
' 1/ulp otherwise', /
977 $
' 6 = 0 if VR same no matter what else computed,',
978 $
' 1/ulp otherwise', /
979 $
' 7 = 0 if VL same no matter what else computed,',
980 $
' 1/ulp otherwise', /
981 $
' 8 = 0 if RCONDV same no matter what else computed,',
982 $
' 1/ulp otherwise', /
983 $
' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
984 $
' computed, 1/ulp otherwise',
985 $ /
' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
986 $ /
' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
987 9994
FORMAT(
' BALANC=''', a1,
''',N=', i4,
',IWK=', i1,
', seed=',
988 $ 4( i4,
',' ),
' type ', i2,
', test(', i2,
')=', g10.3 )
989 9993
FORMAT(
' N=', i5,
', input example =', i3,
', test(', i2,
')=',
991 9992
FORMAT(
' CDRVVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
992 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine cget23(COMP, ISRT, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA, H, W, W1, VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, WORK, LWORK, RWORK, INFO)
CGET23
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 cdrvvx(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NIUNIT, NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, WORK, NWORK, RWORK, INFO)
CDRVVX
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 slabad(SMALL, LARGE)
SLABAD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM