402 SUBROUTINE schkhs( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
403 $ nounit, a, lda, h, t1, t2, u, ldu, z, uz, wr1,
404 $ wi1, wr3, wi3, evectl, evectr, evecty, evectx,
405 $ uu, tau, work, nwork, iwork,
SELECT, result,
414 INTEGER info, lda, ldu, nounit, nsizes, ntypes, nwork
418 LOGICAL dotype( * ), select( * )
419 INTEGER iseed( 4 ), iwork( * ), nn( * )
420 REAL a( lda, * ), evectl( ldu, * ),
421 $ evectr( ldu, * ), evectx( ldu, * ),
422 $ evecty( ldu, * ), h( lda, * ), result( 14 ),
423 $ t1( lda, * ), t2( lda, * ), tau( * ),
424 $ u( ldu, * ), uu( ldu, * ), uz( ldu, * ),
425 $ wi1( * ), wi3( * ), work( * ), wr1( * ),
426 $ wr3( * ), z( ldu, * )
433 parameter( zero = 0.0, one = 1.0 )
435 parameter( maxtyp = 21 )
439 INTEGER i, ihi, iinfo, ilo, imode, in, itype,
j, jcol,
440 $ jj, jsize, jtype, k, mtypes, n, n1, nerrs,
441 $ nmats, nmax, nselc, nselr, ntest, ntestt
442 REAL aninv, anorm, cond, conds, ovfl, rtovfl, rtulp,
443 $ rtulpi, rtunfl, temp1, temp2, ulp, ulpinv, unfl
446 CHARACTER adumma( 1 )
447 INTEGER idumma( 1 ), ioldsd( 4 ), kconds( maxtyp ),
448 $ kmagn( maxtyp ), kmode( maxtyp ),
463 INTRINSIC abs, max, min,
REAL, sqrt
466 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
467 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
469 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
470 $ 1, 5, 5, 5, 4, 3, 1 /
471 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
483 nmax = max( nmax, nn(
j ) )
490 IF( nsizes.LT.0 )
THEN
492 ELSE IF( badnn )
THEN
494 ELSE IF( ntypes.LT.0 )
THEN
496 ELSE IF( thresh.LT.zero )
THEN
498 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
500 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax )
THEN
502 ELSE IF( 4*nmax*nmax+2.GT.nwork )
THEN
507 CALL
xerbla(
'SCHKHS', -info )
513 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
518 unfl =
slamch(
'Safe minimum' )
519 ovfl =
slamch(
'Overflow' )
523 rtunfl = sqrt( unfl )
524 rtovfl = sqrt( ovfl )
533 DO 270 jsize = 1, nsizes
538 aninv = one /
REAL( n1 )
540 IF( nsizes.NE.1 )
THEN
541 mtypes = min( maxtyp, ntypes )
543 mtypes = min( maxtyp+1, ntypes )
546 DO 260 jtype = 1, mtypes
547 IF( .NOT.dotype( jtype ) )
555 ioldsd(
j ) = iseed(
j )
580 IF( mtypes.GT.maxtyp )
583 itype = ktype( jtype )
584 imode = kmode( jtype )
588 go to( 40, 50, 60 )kmagn( jtype )
595 anorm = ( rtovfl*ulp )*aninv
599 anorm = rtunfl*n*ulpinv
604 CALL
slaset(
'Full', lda, n, zero, zero, a, lda )
610 IF( itype.EQ.1 )
THEN
616 ELSE IF( itype.EQ.2 )
THEN
621 a( jcol, jcol ) = anorm
624 ELSE IF( itype.EQ.3 )
THEN
629 a( jcol, jcol ) = anorm
631 $ a( jcol, jcol-1 ) = one
634 ELSE IF( itype.EQ.4 )
THEN
638 CALL
slatms( n, n,
'S', iseed,
'S', work, imode, cond,
639 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
642 ELSE IF( itype.EQ.5 )
THEN
646 CALL
slatms( n, n,
'S', iseed,
'S', work, imode, cond,
647 $ anorm, n, n,
'N', a, lda, work( n+1 ),
650 ELSE IF( itype.EQ.6 )
THEN
654 IF( kconds( jtype ).EQ.1 )
THEN
656 ELSE IF( kconds( jtype ).EQ.2 )
THEN
663 CALL
slatme( n,
'S', iseed, work, imode, cond, one,
664 $ adumma,
'T',
'T',
'T', work( n+1 ), 4,
665 $ conds, n, n, anorm, a, lda, work( 2*n+1 ),
668 ELSE IF( itype.EQ.7 )
THEN
672 CALL
slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
673 $
'T',
'N', work( n+1 ), 1, one,
674 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
675 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
677 ELSE IF( itype.EQ.8 )
THEN
681 CALL
slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
682 $
'T',
'N', work( n+1 ), 1, one,
683 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
684 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
686 ELSE IF( itype.EQ.9 )
THEN
690 CALL
slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
691 $
'T',
'N', work( n+1 ), 1, one,
692 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
693 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
695 ELSE IF( itype.EQ.10 )
THEN
699 CALL
slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
700 $
'T',
'N', work( n+1 ), 1, one,
701 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
702 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
709 IF( iinfo.NE.0 )
THEN
710 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
720 CALL
slacpy(
' ', n, n, a, lda, h, lda )
727 CALL
sgehrd( n, ilo, ihi, h, lda, work, work( n+1 ),
730 IF( iinfo.NE.0 )
THEN
732 WRITE( nounit, fmt = 9999 )
'SGEHRD', iinfo, n, jtype,
741 u( i,
j ) = h( i,
j )
742 uu( i,
j ) = h( i,
j )
746 CALL
scopy( n-1, work, 1, tau, 1 )
747 CALL
sorghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
751 CALL
shst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
752 $ nwork, result( 1 ) )
758 CALL
slacpy(
' ', n, n, h, lda, t2, lda )
762 CALL
shseqr(
'E',
'N', n, ilo, ihi, t2, lda, wr3, wi3, uz,
763 $ ldu, work, nwork, iinfo )
764 IF( iinfo.NE.0 )
THEN
765 WRITE( nounit, fmt = 9999 )
'SHSEQR(E)', iinfo, n, jtype,
767 IF( iinfo.LE.n+2 )
THEN
775 CALL
slacpy(
' ', n, n, h, lda, t2, lda )
777 CALL
shseqr(
'S',
'N', n, ilo, ihi, t2, lda, wr1, wi1, uz,
778 $ ldu, work, nwork, iinfo )
779 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
780 WRITE( nounit, fmt = 9999 )
'SHSEQR(S)', iinfo, n, jtype,
789 CALL
slacpy(
' ', n, n, h, lda, t1, lda )
790 CALL
slacpy(
' ', n, n, u, ldu, uz, lda )
792 CALL
shseqr(
'S',
'V', n, ilo, ihi, t1, lda, wr1, wi1, uz,
793 $ ldu, work, nwork, iinfo )
794 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
795 WRITE( nounit, fmt = 9999 )
'SHSEQR(V)', iinfo, n, jtype,
803 CALL
sgemm(
'T',
'N', n, n, n, one, u, ldu, uz, ldu, zero,
810 CALL
shst01( n, ilo, ihi, h, lda, t1, lda, z, ldu, work,
811 $ nwork, result( 3 ) )
816 CALL
shst01( n, ilo, ihi, a, lda, t1, lda, uz, ldu, work,
817 $ nwork, result( 5 ) )
821 CALL
sget10( n, n, t2, lda, t1, lda, work, result( 7 ) )
828 temp1 = max( temp1, abs( wr1(
j ) )+abs( wi1(
j ) ),
829 $ abs( wr3(
j ) )+abs( wi3(
j ) ) )
830 temp2 = max( temp2, abs( wr1(
j )-wr3(
j ) )+
831 $ abs( wr1(
j )-wr3(
j ) ) )
834 result( 8 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
849 IF( wi1(
j ).EQ.zero )
THEN
850 IF( nselr.LT.max( n / 4, 1 ) )
THEN
854 SELECT(
j ) = .false.
858 IF( nselc.LT.max( n / 4, 1 ) )
THEN
861 SELECT(
j-1 ) = .false.
863 SELECT(
j ) = .false.
864 SELECT(
j-1 ) = .false.
871 CALL
strevc(
'Right',
'All',
SELECT, n, t1, lda, dumma, ldu,
872 $ evectr, ldu, n, in, work, iinfo )
873 IF( iinfo.NE.0 )
THEN
874 WRITE( nounit, fmt = 9999 )
'STREVC(R,A)', iinfo, n,
882 CALL
sget22(
'N',
'N',
'N', n, t1, lda, evectr, ldu, wr1,
883 $ wi1, work, dumma( 1 ) )
884 result( 9 ) = dumma( 1 )
885 IF( dumma( 2 ).GT.thresh )
THEN
886 WRITE( nounit, fmt = 9998 )
'Right',
'STREVC',
887 $ dumma( 2 ), n, jtype, ioldsd
893 CALL
strevc(
'Right',
'Some',
SELECT, n, t1, lda, dumma,
894 $ ldu, evectl, ldu, n, in, work, iinfo )
895 IF( iinfo.NE.0 )
THEN
896 WRITE( nounit, fmt = 9999 )
'STREVC(R,S)', iinfo, n,
905 IF(
SELECT(
j ) .AND. wi1(
j ).EQ.zero )
THEN
907 IF( evectr( jj,
j ).NE.evectl( jj, k ) )
THEN
913 ELSE IF(
SELECT(
j ) .AND. wi1(
j ).NE.zero )
THEN
915 IF( evectr( jj,
j ).NE.evectl( jj, k ) .OR.
916 $ evectr( jj,
j+1 ).NE.evectl( jj, k+1 ) )
THEN
926 $
WRITE( nounit, fmt = 9997 )
'Right',
'STREVC', n, jtype,
932 result( 10 ) = ulpinv
933 CALL
strevc(
'Left',
'All',
SELECT, n, t1, lda, evectl, ldu,
934 $ dumma, ldu, n, in, work, iinfo )
935 IF( iinfo.NE.0 )
THEN
936 WRITE( nounit, fmt = 9999 )
'STREVC(L,A)', iinfo, n,
944 CALL
sget22(
'Trans',
'N',
'Conj', n, t1, lda, evectl, ldu,
945 $ wr1, wi1, work, dumma( 3 ) )
946 result( 10 ) = dumma( 3 )
947 IF( dumma( 4 ).GT.thresh )
THEN
948 WRITE( nounit, fmt = 9998 )
'Left',
'STREVC', dumma( 4 ),
955 CALL
strevc(
'Left',
'Some',
SELECT, n, t1, lda, evectr,
956 $ ldu, dumma, ldu, n, in, work, iinfo )
957 IF( iinfo.NE.0 )
THEN
958 WRITE( nounit, fmt = 9999 )
'STREVC(L,S)', iinfo, n,
967 IF(
SELECT(
j ) .AND. wi1(
j ).EQ.zero )
THEN
969 IF( evectl( jj,
j ).NE.evectr( jj, k ) )
THEN
975 ELSE IF(
SELECT(
j ) .AND. wi1(
j ).NE.zero )
THEN
977 IF( evectl( jj,
j ).NE.evectr( jj, k ) .OR.
978 $ evectl( jj,
j+1 ).NE.evectr( jj, k+1 ) )
THEN
988 $
WRITE( nounit, fmt = 9997 )
'Left',
'STREVC', n, jtype,
994 result( 11 ) = ulpinv
999 CALL
shsein(
'Right',
'Qr',
'Ninitv',
SELECT, n, h, lda,
1000 $ wr3, wi3, dumma, ldu, evectx, ldu, n1, in,
1001 $ work, iwork, iwork, iinfo )
1002 IF( iinfo.NE.0 )
THEN
1003 WRITE( nounit, fmt = 9999 )
'SHSEIN(R)', iinfo, n, jtype,
1014 CALL
sget22(
'N',
'N',
'N', n, h, lda, evectx, ldu, wr3,
1015 $ wi3, work, dumma( 1 ) )
1016 IF( dumma( 1 ).LT.ulpinv )
1017 $ result( 11 ) = dumma( 1 )*aninv
1018 IF( dumma( 2 ).GT.thresh )
THEN
1019 WRITE( nounit, fmt = 9998 )
'Right',
'SHSEIN',
1020 $ dumma( 2 ), n, jtype, ioldsd
1027 result( 12 ) = ulpinv
1029 SELECT(
j ) = .true.
1032 CALL
shsein(
'Left',
'Qr',
'Ninitv',
SELECT, n, h, lda, wr3,
1033 $ wi3, evecty, ldu, dumma, ldu, n1, in, work,
1034 $ iwork, iwork, iinfo )
1035 IF( iinfo.NE.0 )
THEN
1036 WRITE( nounit, fmt = 9999 )
'SHSEIN(L)', iinfo, n, jtype,
1047 CALL
sget22(
'C',
'N',
'C', n, h, lda, evecty, ldu, wr3,
1048 $ wi3, work, dumma( 3 ) )
1049 IF( dumma( 3 ).LT.ulpinv )
1050 $ result( 12 ) = dumma( 3 )*aninv
1051 IF( dumma( 4 ).GT.thresh )
THEN
1052 WRITE( nounit, fmt = 9998 )
'Left',
'SHSEIN',
1053 $ dumma( 4 ), n, jtype, ioldsd
1060 result( 13 ) = ulpinv
1062 CALL
sormhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1063 $ ldu, tau, evectx, ldu, work, nwork, iinfo )
1064 IF( iinfo.NE.0 )
THEN
1065 WRITE( nounit, fmt = 9999 )
'SORMHR(R)', iinfo, n, jtype,
1076 CALL
sget22(
'N',
'N',
'N', n, a, lda, evectx, ldu, wr3,
1077 $ wi3, work, dumma( 1 ) )
1078 IF( dumma( 1 ).LT.ulpinv )
1079 $ result( 13 ) = dumma( 1 )*aninv
1085 result( 14 ) = ulpinv
1087 CALL
sormhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1088 $ ldu, tau, evecty, ldu, work, nwork, iinfo )
1089 IF( iinfo.NE.0 )
THEN
1090 WRITE( nounit, fmt = 9999 )
'SORMHR(L)', iinfo, n, jtype,
1101 CALL
sget22(
'C',
'N',
'C', n, a, lda, evecty, ldu, wr3,
1102 $ wi3, work, dumma( 3 ) )
1103 IF( dumma( 3 ).LT.ulpinv )
1104 $ result( 14 ) = dumma( 3 )*aninv
1111 ntestt = ntestt + ntest
1112 CALL
slafts(
'SHS', n, n, jtype, ntest, result, ioldsd,
1113 $ thresh, nounit, nerrs )
1120 CALL
slasum(
'SHS', nounit, nerrs, ntestt )
1124 9999
FORMAT(
' SCHKHS: ', a,
' returned INFO=', i6,
'.', / 9
x,
'N=',
1125 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1126 9998
FORMAT(
' SCHKHS: ', a,
' Eigenvectors from ', a,
' incorrectly ',
1127 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9
x,
1128 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
1130 9997
FORMAT(
' SCHKHS: Selected ', a,
' Eigenvectors from ', a,
1131 $
' do not match other eigenvectors ', 9
x,
'N=', i6,
1132 $
', 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...
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 shseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
SHSEQR
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine schkhs(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1, WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX, UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT, INFO)
SCHKHS
subroutine sget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, WI, WORK, RESULT)
SGET22
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sormhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMHR
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
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 sorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SORGHR
subroutine slatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
SLATME
subroutine strevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
STREVC
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD
subroutine shsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO)
SHSEIN
subroutine sget10(M, N, A, LDA, B, LDB, WORK, RESULT)
SGET10
subroutine slafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
SLAFTS