377 SUBROUTINE zdrves( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
378 $ nounit, a, lda, h, ht, w, wt, vs, ldvs, result,
379 $ work, nwork, rwork, iwork, bwork, info )
387 INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
388 DOUBLE PRECISION THRESH
391 LOGICAL BWORK( * ), DOTYPE( * )
392 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
393 DOUBLE PRECISION RESULT( 13 ), RWORK( * )
394 COMPLEX*16 A( lda, * ), H( lda, * ), HT( lda, * ),
395 $ vs( ldvs, * ), w( * ), work( * ), wt( * )
402 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
404 parameter ( cone = ( 1.0d+0, 0.0d+0 ) )
405 DOUBLE PRECISION ZERO, ONE
406 parameter ( zero = 0.0d+0, one = 1.0d+0 )
408 parameter ( maxtyp = 21 )
414 INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
415 $ jsize, jtype, knteig, lwork, mtypes, n, nerrs,
416 $ nfail, nmax, nnwork, ntest, ntestf, ntestt,
418 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
422 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
423 $ kmagn( maxtyp ), kmode( maxtyp ),
425 DOUBLE PRECISION RES( 2 )
429 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
432 INTEGER SELDIM, SELOPT
435 COMMON / sslct / selopt, seldim, selval, selwr, selwi
439 DOUBLE PRECISION DLAMCH
440 EXTERNAL zslect, dlamch
447 INTRINSIC abs, dcmplx, max, min, sqrt
450 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
451 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
453 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
454 $ 1, 5, 5, 5, 4, 3, 1 /
455 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
459 path( 1: 1 ) =
'Zomplex precision'
474 nmax = max( nmax, nn( j ) )
481 IF( nsizes.LT.0 )
THEN
483 ELSE IF( badnn )
THEN
485 ELSE IF( ntypes.LT.0 )
THEN
487 ELSE IF( thresh.LT.zero )
THEN
489 ELSE IF( nounit.LE.0 )
THEN
491 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
493 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax )
THEN
495 ELSE IF( 5*nmax+2*nmax**2.GT.nwork )
THEN
500 CALL xerbla(
'ZDRVES', -info )
506 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
511 unfl = dlamch(
'Safe minimum' )
514 ulp = dlamch(
'Precision' )
523 DO 240 jsize = 1, nsizes
525 IF( nsizes.NE.1 )
THEN
526 mtypes = min( maxtyp, ntypes )
528 mtypes = min( maxtyp+1, ntypes )
531 DO 230 jtype = 1, mtypes
532 IF( .NOT.dotype( jtype ) )
538 ioldsd( j ) = iseed( j )
557 IF( mtypes.GT.maxtyp )
560 itype = ktype( jtype )
561 imode = kmode( jtype )
565 GO TO ( 30, 40, 50 )kmagn( jtype )
581 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
587 IF( itype.EQ.1 )
THEN
593 ELSE IF( itype.EQ.2 )
THEN
598 a( jcol, jcol ) = dcmplx( anorm )
601 ELSE IF( itype.EQ.3 )
THEN
606 a( jcol, jcol ) = dcmplx( anorm )
608 $ a( jcol, jcol-1 ) = cone
611 ELSE IF( itype.EQ.4 )
THEN
615 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
616 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
619 ELSE IF( itype.EQ.5 )
THEN
623 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
624 $ anorm, n, n,
'N', a, lda, work( n+1 ),
627 ELSE IF( itype.EQ.6 )
THEN
631 IF( kconds( jtype ).EQ.1 )
THEN
633 ELSE IF( kconds( jtype ).EQ.2 )
THEN
639 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
640 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
641 $ a, lda, work( 2*n+1 ), iinfo )
643 ELSE IF( itype.EQ.7 )
THEN
647 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
648 $
'T',
'N', work( n+1 ), 1, one,
649 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
650 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
652 ELSE IF( itype.EQ.8 )
THEN
656 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
657 $
'T',
'N', work( n+1 ), 1, one,
658 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
659 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
661 ELSE IF( itype.EQ.9 )
THEN
665 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
666 $
'T',
'N', work( n+1 ), 1, one,
667 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
668 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
670 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
671 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
673 CALL zlaset(
'Full', n-3, 2, czero, czero,
675 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
679 ELSE IF( itype.EQ.10 )
THEN
683 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
684 $
'T',
'N', work( n+1 ), 1, one,
685 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
686 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
693 IF( iinfo.NE.0 )
THEN
694 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
708 nnwork = 5*n + 2*n**2
710 nnwork = max( nnwork, 1 )
721 IF( isort.EQ.0 )
THEN
731 CALL zlacpy(
'F', n, n, a, lda, h, lda )
732 CALL zgees(
'V', sort, zslect, n, h, lda, sdim, w, vs,
733 $ ldvs, work, nnwork, rwork, bwork, iinfo )
734 IF( iinfo.NE.0 )
THEN
735 result( 1+rsub ) = ulpinv
736 WRITE( nounit, fmt = 9992 )
'ZGEES1', iinfo, n,
744 result( 1+rsub ) = zero
747 IF( h( i, j ).NE.zero )
748 $ result( 1+rsub ) = ulpinv
754 lwork = max( 1, 2*n*n )
755 CALL zhst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
756 $ lwork, rwork, res )
757 result( 2+rsub ) = res( 1 )
758 result( 3+rsub ) = res( 2 )
762 result( 4+rsub ) = zero
764 IF( h( i, i ).NE.w( i ) )
765 $ result( 4+rsub ) = ulpinv
770 CALL zlacpy(
'F', n, n, a, lda, ht, lda )
771 CALL zgees(
'N', sort, zslect, n, ht, lda, sdim, wt,
772 $ vs, ldvs, work, nnwork, rwork, bwork,
774 IF( iinfo.NE.0 )
THEN
775 result( 5+rsub ) = ulpinv
776 WRITE( nounit, fmt = 9992 )
'ZGEES2', iinfo, n,
782 result( 5+rsub ) = zero
785 IF( h( i, j ).NE.ht( i, j ) )
786 $ result( 5+rsub ) = ulpinv
792 result( 6+rsub ) = zero
794 IF( w( i ).NE.wt( i ) )
795 $ result( 6+rsub ) = ulpinv
800 IF( isort.EQ.1 )
THEN
804 IF( zslect( w( i ) ) )
805 $ knteig = knteig + 1
807 IF( zslect( w( i+1 ) ) .AND.
808 $ ( .NOT.zslect( w( i ) ) ) )result( 13 )
813 $ result( 13 ) = ulpinv
825 IF( result( j ).GE.zero )
827 IF( result( j ).GE.thresh )
832 $ ntestf = ntestf + 1
833 IF( ntestf.EQ.1 )
THEN
834 WRITE( nounit, fmt = 9999 )path
835 WRITE( nounit, fmt = 9998 )
836 WRITE( nounit, fmt = 9997 )
837 WRITE( nounit, fmt = 9996 )
838 WRITE( nounit, fmt = 9995 )thresh
839 WRITE( nounit, fmt = 9994 )
844 IF( result( j ).GE.thresh )
THEN
845 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
850 nerrs = nerrs + nfail
851 ntestt = ntestt + ntest
859 CALL dlasum( path, nounit, nerrs, ntestt )
861 9999
FORMAT( / 1x, a3,
' -- Complex Schur Form Decomposition Driver',
862 $ /
' Matrix types (see ZDRVES for details): ' )
864 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
865 $
' ',
' 5=Diagonal: geometr. spaced entries.',
866 $ /
' 2=Identity matrix. ',
' 6=Diagona',
867 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
868 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
869 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
870 $
'mall, evenly spaced.' )
871 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
872 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
873 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
874 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
875 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
876 $
'lex ', a6, /
' 12=Well-cond., random complex ', a6,
' ',
877 $
' 17=Ill-cond., large rand. complx ', a4, /
' 13=Ill-condi',
878 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
880 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
881 $
'with small random entries.', /
' 20=Matrix with large ran',
882 $
'dom entries. ', / )
883 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
884 $ /
' ( A denotes A on input and T denotes A on output)',
885 $ / /
' 1 = 0 if T in Schur form (no sort), ',
886 $
' 1/ulp otherwise', /
887 $
' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
888 $ /
' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ',
889 $ /
' 4 = 0 if W are eigenvalues of T (no sort),',
890 $
' 1/ulp otherwise', /
891 $
' 5 = 0 if T same no matter if VS computed (no sort),',
892 $
' 1/ulp otherwise', /
893 $
' 6 = 0 if W same no matter if VS computed (no sort)',
894 $
', 1/ulp otherwise' )
895 9994
FORMAT(
' 7 = 0 if T in Schur form (sort), ',
' 1/ulp otherwise',
896 $ /
' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
897 $ /
' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
898 $ /
' 10 = 0 if W are eigenvalues of T (sort),',
899 $
' 1/ulp otherwise', /
900 $
' 11 = 0 if T same no matter if VS computed (sort),',
901 $
' 1/ulp otherwise', /
902 $
' 12 = 0 if W same no matter if VS computed (sort),',
903 $
' 1/ulp otherwise', /
904 $
' 13 = 0 if sorting successful, 1/ulp otherwise', / )
905 9993
FORMAT(
' N=', i5,
', IWK=', i2,
', seed=', 4( i4,
',' ),
906 $
' type ', i2,
', test(', i2,
')=', g10.3 )
907 9992
FORMAT(
' ZDRVES: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
908 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine zlatmr(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)
ZLATMR
subroutine zdrves(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT, WORK, NWORK, RWORK, IWORK, BWORK, INFO)
ZDRVES
subroutine zgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO)
ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
ZHST01
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine zlatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
ZLATME
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS