431 SUBROUTINE zdrvsx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
432 $ NIUNIT, NOUNIT, A, LDA, H, HT, W, WT, WTMP, VS,
433 $ LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK,
441 INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
443 DOUBLE PRECISION THRESH
446 LOGICAL BWORK( * ), DOTYPE( * )
447 INTEGER ISEED( 4 ), NN( * )
448 DOUBLE PRECISION RESULT( 17 ), RWORK( * )
449 COMPLEX*16 A( LDA, * ), H( LDA, * ), HT( LDA, * ),
450 $ vs( ldvs, * ), vs1( ldvs, * ), w( * ),
451 $ work( * ), wt( * ), wtmp( * )
458 PARAMETER ( CZERO = ( 0.0d+0, 0.0d+0 ) )
460 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
461 DOUBLE PRECISION ZERO, ONE
462 parameter( zero = 0.0d+0, one = 1.0d+0 )
464 parameter( maxtyp = 21 )
469 INTEGER I, IINFO, IMODE, ISRT, ITYPE, IWK, J, JCOL,
470 $ jsize, jtype, mtypes, n, nerrs, nfail, nmax,
471 $ nnwork, nslct, ntest, ntestf, ntestt
472 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RCDEIN, RCDVIN,
473 $ RTULP, RTULPI, ULP, ULPINV, UNFL
476 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISLCT( 20 ),
477 $ KCONDS( MAXTYP ), KMAGN( MAXTYP ),
478 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
482 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
485 INTEGER SELDIM, SELOPT
488 COMMON / sslct / selopt, seldim, selval, selwr, selwi
491 DOUBLE PRECISION DLAMCH
499 INTRINSIC abs, max, min, sqrt
502 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
503 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
505 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
506 $ 1, 5, 5, 5, 4, 3, 1 /
507 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
511 path( 1: 1 ) =
'Zomplex precision'
529 nmax = max( nmax, nn( j ) )
536 IF( nsizes.LT.0 )
THEN
538 ELSE IF( badnn )
THEN
540 ELSE IF( ntypes.LT.0 )
THEN
542 ELSE IF( thresh.LT.zero )
THEN
544 ELSE IF( niunit.LE.0 )
THEN
546 ELSE IF( nounit.LE.0 )
THEN
548 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
550 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax )
THEN
552 ELSE IF( max( 3*nmax, 2*nmax**2 ).GT.lwork )
THEN
557 CALL xerbla(
'ZDRVSX', -info )
563 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
568 unfl = dlamch(
'Safe minimum' )
570 ulp = dlamch(
'Precision' )
579 DO 140 jsize = 1, nsizes
581 IF( nsizes.NE.1 )
THEN
582 mtypes = min( maxtyp, ntypes )
584 mtypes = min( maxtyp+1, ntypes )
587 DO 130 jtype = 1, mtypes
588 IF( .NOT.dotype( jtype ) )
594 ioldsd( j ) = iseed( j )
613 IF( mtypes.GT.maxtyp )
616 itype = ktype( jtype )
617 imode = kmode( jtype )
621 GO TO ( 30, 40, 50 )kmagn( jtype )
637 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
643 IF( itype.EQ.1 )
THEN
649 ELSE IF( itype.EQ.2 )
THEN
654 a( jcol, jcol ) = anorm
657 ELSE IF( itype.EQ.3 )
THEN
662 a( jcol, jcol ) = anorm
664 $ a( jcol, jcol-1 ) = cone
667 ELSE IF( itype.EQ.4 )
THEN
671 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
672 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
675 ELSE IF( itype.EQ.5 )
THEN
679 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
680 $ anorm, n, n,
'N', a, lda, work( n+1 ),
683 ELSE IF( itype.EQ.6 )
THEN
687 IF( kconds( jtype ).EQ.1 )
THEN
689 ELSE IF( kconds( jtype ).EQ.2 )
THEN
695 CALL zlatme( n,
'D', iseed, work, imode, cond, cone,
696 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
697 $ a, lda, work( 2*n+1 ), iinfo )
699 ELSE IF( itype.EQ.7 )
THEN
703 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
704 $
'T',
'N', work( n+1 ), 1, one,
705 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
706 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
708 ELSE IF( itype.EQ.8 )
THEN
712 CALL zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
713 $
'T',
'N', work( n+1 ), 1, one,
714 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
715 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
717 ELSE IF( itype.EQ.9 )
THEN
721 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
722 $
'T',
'N', work( n+1 ), 1, one,
723 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
724 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
726 CALL zlaset(
'Full', 2, n, czero, czero, a, lda )
727 CALL zlaset(
'Full', n-3, 1, czero, czero, a( 3, 1 ),
729 CALL zlaset(
'Full', n-3, 2, czero, czero,
731 CALL zlaset(
'Full', 1, n, czero, czero, a( n, 1 ),
735 ELSE IF( itype.EQ.10 )
THEN
739 CALL zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
740 $
'T',
'N', work( n+1 ), 1, one,
741 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
742 $ zero, anorm,
'NO', a, lda, idumma, iinfo )
749 IF( iinfo.NE.0 )
THEN
750 WRITE( nounit, fmt = 9991 )
'Generator', iinfo, n, jtype,
764 nnwork = max( 2*n, n*( n+1 ) / 2 )
766 nnwork = max( nnwork, 1 )
768 CALL zget24( .false., jtype, thresh, ioldsd, nounit, n,
769 $ a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1,
770 $ rcdein, rcdvin, nslct, islct, 0, result,
771 $ work, nnwork, rwork, bwork, info )
778 IF( result( j ).GE.zero )
780 IF( result( j ).GE.thresh )
785 $ ntestf = ntestf + 1
786 IF( ntestf.EQ.1 )
THEN
787 WRITE( nounit, fmt = 9999 )path
788 WRITE( nounit, fmt = 9998 )
789 WRITE( nounit, fmt = 9997 )
790 WRITE( nounit, fmt = 9996 )
791 WRITE( nounit, fmt = 9995 )thresh
792 WRITE( nounit, fmt = 9994 )
797 IF( result( j ).GE.thresh )
THEN
798 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
803 nerrs = nerrs + nfail
804 ntestt = ntestt + ntest
817 READ( niunit, fmt = *,
END = 200 )N, NSLCT, isrt
822 READ( niunit, fmt = * )( islct( i ), i = 1, nslct )
824 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
826 READ( niunit, fmt = * )rcdein, rcdvin
828 CALL zget24( .true., 22, thresh, iseed, nounit, n, a, lda, h, ht,
829 $ w, wt, wtmp, vs, ldvs, vs1, rcdein, rcdvin, nslct,
830 $ islct, isrt, result, work, lwork, rwork, bwork,
838 IF( result( j ).GE.zero )
840 IF( result( j ).GE.thresh )
845 $ ntestf = ntestf + 1
846 IF( ntestf.EQ.1 )
THEN
847 WRITE( nounit, fmt = 9999 )path
848 WRITE( nounit, fmt = 9998 )
849 WRITE( nounit, fmt = 9997 )
850 WRITE( nounit, fmt = 9996 )
851 WRITE( nounit, fmt = 9995 )thresh
852 WRITE( nounit, fmt = 9994 )
856 IF( result( j ).GE.thresh )
THEN
857 WRITE( nounit, fmt = 9992 )n, jtype, j, result( j )
861 nerrs = nerrs + nfail
862 ntestt = ntestt + ntest
868 CALL dlasum( path, nounit, nerrs, ntestt )
870 9999
FORMAT( / 1x, a3,
' -- Complex Schur Form Decomposition Expert ',
871 $
'Driver', /
' Matrix types (see ZDRVSX for details): ' )
873 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
874 $
' ',
' 5=Diagonal: geometr. spaced entries.',
875 $ /
' 2=Identity matrix. ',
' 6=Diagona',
876 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
877 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
878 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
879 $
'mall, evenly spaced.' )
880 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
881 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
882 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
883 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
884 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
885 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
886 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
887 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
889 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
890 $
'with small random entries.', /
' 20=Matrix with large ran',
891 $
'dom entries. ', / )
892 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
893 $ /
' ( A denotes A on input and T denotes A on output)',
894 $ / /
' 1 = 0 if T in Schur form (no sort), ',
895 $
' 1/ulp otherwise', /
896 $
' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
897 $ /
' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ',
898 $ /
' 4 = 0 if W are eigenvalues of T (no sort),',
899 $
' 1/ulp otherwise', /
900 $
' 5 = 0 if T same no matter if VS computed (no sort),',
901 $
' 1/ulp otherwise', /
902 $
' 6 = 0 if W same no matter if VS computed (no sort)',
903 $
', 1/ulp otherwise' )
904 9994
FORMAT(
' 7 = 0 if T in Schur form (sort), ',
' 1/ulp otherwise',
905 $ /
' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
906 $ /
' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
907 $ /
' 10 = 0 if W are eigenvalues of T (sort),',
908 $
' 1/ulp otherwise', /
909 $
' 11 = 0 if T same no matter what else computed (sort),',
910 $
' 1/ulp otherwise', /
911 $
' 12 = 0 if W same no matter what else computed ',
912 $
'(sort), 1/ulp otherwise', /
913 $
' 13 = 0 if sorting successful, 1/ulp otherwise',
914 $ /
' 14 = 0 if RCONDE same no matter what else computed,',
915 $
' 1/ulp otherwise', /
916 $
' 15 = 0 if RCONDv same no matter what else computed,',
917 $
' 1/ulp otherwise', /
918 $
' 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),',
919 $ /
' 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),' )
920 9993
FORMAT(
' N=', i5,
', IWK=', i2,
', seed=', 4( i4,
',' ),
921 $
' type ', i2,
', test(', i2,
')=', g10.3 )
922 9992
FORMAT(
' N=', i5,
', input example =', i3,
', test(', i2,
')=',
924 9991
FORMAT(
' ZDRVSX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
925 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine xerbla(srname, info)
subroutine dlasum(type, iounit, ie, nrun)
DLASUM
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 zdrvsx(nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1, result, work, lwork, rwork, bwork, info)
ZDRVSX
subroutine zget24(comp, jtype, thresh, iseed, nounit, n, a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1, rcdein, rcdvin, nslct, islct, isrt, result, work, lwork, rwork, bwork, info)
ZGET24
subroutine zlatme(n, dist, iseed, d, mode, cond, dmax, rsign, upper, sim, ds, modes, conds, kl, ku, anorm, a, lda, work, info)
ZLATME
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 zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS