387 SUBROUTINE sdrves( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
388 $ nounit, a, lda, h, ht, wr, wi, wrt, wit, vs,
389 $ ldvs, result, work, nwork, iwork, bwork, info )
397 INTEGER info, lda, ldvs, nounit, nsizes, ntypes, nwork
401 LOGICAL bwork( * ), dotype( * )
402 INTEGER iseed( 4 ), iwork( * ), nn( * )
403 REAL a( lda, * ), h( lda, * ), ht( lda, * ),
404 $ result( 13 ), vs( ldvs, * ), wi( * ), wit( * ),
405 $ work( * ), wr( * ), wrt( * )
412 parameter( zero = 0.0e0, one = 1.0e0 )
414 parameter( maxtyp = 21 )
420 INTEGER i, iinfo, imode, isort, itype, iwk,
j, jcol,
421 $ jsize, jtype, knteig, lwork, mtypes, n,
422 $ nerrs, nfail, nmax, nnwork, ntest, ntestf,
424 REAL anorm, cond, conds, ovfl, rtulp, rtulpi, tmp,
428 CHARACTER adumma( 1 )
429 INTEGER idumma( 1 ), ioldsd( 4 ), kconds( maxtyp ),
430 $ kmagn( maxtyp ), kmode( maxtyp ),
436 REAL selwi( 20 ), selwr( 20 )
439 INTEGER seldim, selopt
442 COMMON / sslct / selopt, seldim, selval, selwr, selwi
454 INTRINSIC abs, max, sign, sqrt
457 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
458 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
460 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
461 $ 1, 5, 5, 5, 4, 3, 1 /
462 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
466 path( 1: 1 ) =
'Single precision'
481 nmax = max( nmax, nn(
j ) )
488 IF( nsizes.LT.0 )
THEN
490 ELSE IF( badnn )
THEN
492 ELSE IF( ntypes.LT.0 )
THEN
494 ELSE IF( thresh.LT.zero )
THEN
496 ELSE IF( nounit.LE.0 )
THEN
498 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
500 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax )
THEN
502 ELSE IF( 5*nmax+2*nmax**2.GT.nwork )
THEN
507 CALL
xerbla(
'SDRVES', -info )
513 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
518 unfl =
slamch(
'Safe minimum' )
521 ulp =
slamch(
'Precision' )
530 DO 270 jsize = 1, nsizes
533 IF( nsizes.EQ.1 .AND. ntypes.EQ.maxtyp+1 )
534 $ mtypes = mtypes + 1
536 DO 260 jtype = 1, mtypes
537 IF( .NOT.dotype( jtype ) )
543 ioldsd(
j ) = iseed(
j )
562 IF( mtypes.GT.maxtyp )
565 itype = ktype( jtype )
566 imode = kmode( jtype )
570 go to( 30, 40, 50 )kmagn( jtype )
586 CALL
slaset(
'Full', lda, n, zero, zero, a, lda )
594 IF( itype.EQ.1 )
THEN
597 ELSE IF( itype.EQ.2 )
THEN
602 a( jcol, jcol ) = anorm
605 ELSE IF( itype.EQ.3 )
THEN
610 a( jcol, jcol ) = anorm
612 $ a( jcol, jcol-1 ) = one
615 ELSE IF( itype.EQ.4 )
THEN
619 CALL
slatms( n, n,
'S', iseed,
'S', work, imode, cond,
620 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
623 ELSE IF( itype.EQ.5 )
THEN
627 CALL
slatms( n, n,
'S', iseed,
'S', work, imode, cond,
628 $ anorm, n, n,
'N', a, lda, work( n+1 ),
631 ELSE IF( itype.EQ.6 )
THEN
635 IF( kconds( jtype ).EQ.1 )
THEN
637 ELSE IF( kconds( jtype ).EQ.2 )
THEN
644 CALL
slatme( n,
'S', iseed, work, imode, cond, one,
645 $ adumma,
'T',
'T',
'T', work( n+1 ), 4,
646 $ conds, n, n, anorm, a, lda, work( 2*n+1 ),
649 ELSE IF( itype.EQ.7 )
THEN
653 CALL
slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
654 $
'T',
'N', work( n+1 ), 1, one,
655 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
656 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
658 ELSE IF( itype.EQ.8 )
THEN
662 CALL
slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
663 $
'T',
'N', work( n+1 ), 1, one,
664 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
665 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
667 ELSE IF( itype.EQ.9 )
THEN
671 CALL
slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
672 $
'T',
'N', work( n+1 ), 1, one,
673 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
674 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
676 CALL
slaset(
'Full', 2, n, zero, zero, a, lda )
677 CALL
slaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
679 CALL
slaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
681 CALL
slaset(
'Full', 1, n, zero, zero, a( n, 1 ),
685 ELSE IF( itype.EQ.10 )
THEN
689 CALL
slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
690 $
'T',
'N', work( n+1 ), 1, one,
691 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
692 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
699 IF( iinfo.NE.0 )
THEN
700 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
714 nnwork = 5*n + 2*n**2
716 nnwork = max( nnwork, 1 )
727 IF( isort.EQ.0 )
THEN
737 CALL
slacpy(
'F', n, n, a, lda, h, lda )
738 CALL
sgees(
'V', sort,
sslect, n, h, lda, sdim, wr,
739 $ wi, vs, ldvs, work, nnwork, bwork, iinfo )
740 IF( iinfo.NE.0 .AND. iinfo.NE.n+2 )
THEN
741 result( 1+rsub ) = ulpinv
742 WRITE( nounit, fmt = 9992 )
'SGEES1', iinfo, n,
750 result( 1+rsub ) = zero
753 IF( h( i,
j ).NE.zero )
754 $ result( 1+rsub ) = ulpinv
758 IF( h( i+1, i ).NE.zero .AND. h( i+2, i+1 ).NE.
759 $ zero )result( 1+rsub ) = ulpinv
762 IF( h( i+1, i ).NE.zero )
THEN
763 IF( h( i, i ).NE.h( i+1, i+1 ) .OR.
764 $ h( i, i+1 ).EQ.zero .OR.
765 $ sign( one, h( i+1, i ) ).EQ.
766 $ sign( one, h( i, i+1 ) ) )result( 1+rsub )
773 lwork = max( 1, 2*n*n )
774 CALL
shst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
776 result( 2+rsub ) = res( 1 )
777 result( 3+rsub ) = res( 2 )
781 result( 4+rsub ) = zero
783 IF( h( i, i ).NE.wr( i ) )
784 $ result( 4+rsub ) = ulpinv
787 IF( h( 2, 1 ).EQ.zero .AND. wi( 1 ).NE.zero )
788 $ result( 4+rsub ) = ulpinv
789 IF( h( n, n-1 ).EQ.zero .AND. wi( n ).NE.zero )
790 $ result( 4+rsub ) = ulpinv
793 IF( h( i+1, i ).NE.zero )
THEN
794 tmp = sqrt( abs( h( i+1, i ) ) )*
795 $ sqrt( abs( h( i, i+1 ) ) )
796 result( 4+rsub ) = max( result( 4+rsub ),
797 $ abs( wi( i )-tmp ) /
798 $ max( ulp*tmp, unfl ) )
799 result( 4+rsub ) = max( result( 4+rsub ),
800 $ abs( wi( i+1 )+tmp ) /
801 $ max( ulp*tmp, unfl ) )
802 ELSE IF( i.GT.1 )
THEN
803 IF( h( i+1, i ).EQ.zero .AND. h( i, i-1 ).EQ.
804 $ zero .AND. wi( i ).NE.zero )result( 4+rsub )
811 CALL
slacpy(
'F', n, n, a, lda, ht, lda )
812 CALL
sgees(
'N', sort,
sslect, n, ht, lda, sdim, wrt,
813 $ wit, vs, ldvs, work, nnwork, bwork,
815 IF( iinfo.NE.0 .AND. iinfo.NE.n+2 )
THEN
816 result( 5+rsub ) = ulpinv
817 WRITE( nounit, fmt = 9992 )
'SGEES2', iinfo, n,
823 result( 5+rsub ) = zero
826 IF( h( i,
j ).NE.ht( i,
j ) )
827 $ result( 5+rsub ) = ulpinv
833 result( 6+rsub ) = zero
835 IF( wr( i ).NE.wrt( i ) .OR. wi( i ).NE.wit( i ) )
836 $ result( 6+rsub ) = ulpinv
841 IF( isort.EQ.1 )
THEN
845 IF(
sslect( wr( i ), wi( i ) ) .OR.
846 $
sslect( wr( i ), -wi( i ) ) )
847 $ knteig = knteig + 1
850 $ wi( i+1 ) ) .OR.
sslect( wr( i+1 ),
851 $ -wi( i+1 ) ) ) .AND.
852 $ ( .NOT.(
sslect( wr( i ),
853 $ wi( i ) ) .OR.
sslect( wr( i ),
854 $ -wi( i ) ) ) ) .AND. iinfo.NE.n+2 )
855 $ result( 13 ) = ulpinv
858 IF( sdim.NE.knteig )
THEN
859 result( 13 ) = ulpinv
872 IF( result(
j ).GE.zero )
874 IF( result(
j ).GE.thresh )
879 $ ntestf = ntestf + 1
880 IF( ntestf.EQ.1 )
THEN
881 WRITE( nounit, fmt = 9999 )path
882 WRITE( nounit, fmt = 9998 )
883 WRITE( nounit, fmt = 9997 )
884 WRITE( nounit, fmt = 9996 )
885 WRITE( nounit, fmt = 9995 )thresh
886 WRITE( nounit, fmt = 9994 )
891 IF( result(
j ).GE.thresh )
THEN
892 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
897 nerrs = nerrs + nfail
898 ntestt = ntestt + ntest
906 CALL
slasum( path, nounit, nerrs, ntestt )
908 9999
FORMAT( / 1
x, a3,
' -- Real Schur Form Decomposition Driver',
909 $ /
' Matrix types (see SDRVES for details): ' )
911 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
912 $
' ',
' 5=Diagonal: geometr. spaced entries.',
913 $ /
' 2=Identity matrix. ',
' 6=Diagona',
914 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
915 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
916 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
917 $
'mall, evenly spaced.' )
918 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
919 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
920 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
921 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
922 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
923 $
'lex ', /
' 12=Well-cond., random complex ', 6
x,
' ',
924 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
925 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
927 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
928 $
'with small random entries.', /
' 20=Matrix with large ran',
929 $
'dom entries. ', / )
930 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
931 $ /
' ( A denotes A on input and T denotes A on output)',
932 $ / /
' 1 = 0 if T in Schur form (no sort), ',
933 $
' 1/ulp otherwise', /
934 $
' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
935 $ /
' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
936 $
' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
937 $
' 1/ulp otherwise', /
938 $
' 5 = 0 if T same no matter if VS computed (no sort),',
939 $
' 1/ulp otherwise', /
940 $
' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
941 $
', 1/ulp otherwise' )
942 9994
FORMAT(
' 7 = 0 if T in Schur form (sort), ',
' 1/ulp otherwise',
943 $ /
' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
944 $ /
' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
945 $ /
' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
946 $
' 1/ulp otherwise', /
947 $
' 11 = 0 if T same no matter if VS computed (sort),',
948 $
' 1/ulp otherwise', /
949 $
' 12 = 0 if WR, WI same no matter if VS computed (sort),',
950 $
' 1/ulp otherwise', /
951 $
' 13 = 0 if sorting succesful, 1/ulp otherwise', / )
952 9993
FORMAT(
' N=', i5,
', IWK=', i2,
', seed=', 4( i4,
',' ),
953 $
' type ', i2,
', test(', i2,
')=', g10.3 )
954 9992
FORMAT(
' SDRVES: ', a,
' returned INFO=', i6,
'.', / 9
x,
'N=',
955 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
LOGICAL function sslect(ZR, ZI)
SSLECT
REAL function slamch(CMACH)
SLAMCH
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine slatmr(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)
SLATMR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine shst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
SHST01
subroutine sdrves(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO)
SDRVES
subroutine sgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
SGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
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 slatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
SLATME