402 SUBROUTINE dchkhs( 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
415 DOUBLE PRECISION THRESH
418 LOGICAL DOTYPE( * ), SELECT( * )
419 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
420 DOUBLE PRECISION 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, * )
432 DOUBLE PRECISION ZERO, ONE
433 parameter( zero = 0.0d0, one = 1.0d0 )
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 DOUBLE PRECISION 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 ),
450 DOUBLE PRECISION DUMMA( 6 )
453 DOUBLE PRECISION DLAMCH
463 INTRINSIC abs, dble, max, min, 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(
'DCHKHS', -info )
513 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
518 unfl = dlamch(
'Safe minimum' )
519 ovfl = dlamch(
'Overflow' )
521 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
523 rtunfl = sqrt( unfl )
524 rtovfl = sqrt( ovfl )
533 DO 270 jsize = 1, nsizes
538 aninv = one / dble( 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 dlaset(
'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 dlatms( 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 dlatms( 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 dlatme( 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 dlatmr( 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 dlatmr( 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 dlatmr( 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 dlatmr( 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 dlacpy(
' ', n, n, a, lda, h, lda )
727 CALL dgehrd( n, ilo, ihi, h, lda, work, work( n+1 ),
730 IF( iinfo.NE.0 )
THEN
732 WRITE( nounit, fmt = 9999 )
'DGEHRD', iinfo, n, jtype,
741 u( i, j ) = h( i, j )
742 uu( i, j ) = h( i, j )
746 CALL dcopy( n-1, work, 1, tau, 1 )
747 CALL dorghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
751 CALL dhst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
752 $ nwork, result( 1 ) )
758 CALL dlacpy(
' ', n, n, h, lda, t2, lda )
762 CALL dhseqr(
'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 )
'DHSEQR(E)', iinfo, n, jtype,
767 IF( iinfo.LE.n+2 )
THEN
775 CALL dlacpy(
' ', n, n, h, lda, t2, lda )
777 CALL dhseqr(
'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 )
'DHSEQR(S)', iinfo, n, jtype,
789 CALL dlacpy(
' ', n, n, h, lda, t1, lda )
790 CALL dlacpy(
' ', n, n, u, ldu, uz, lda )
792 CALL dhseqr(
'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 )
'DHSEQR(V)', iinfo, n, jtype,
803 CALL dgemm(
'T',
'N', n, n, n, one, u, ldu, uz, ldu, zero,
810 CALL dhst01( n, ilo, ihi, h, lda, t1, lda, z, ldu, work,
811 $ nwork, result( 3 ) )
816 CALL dhst01( n, ilo, ihi, a, lda, t1, lda, uz, ldu, work,
817 $ nwork, result( 5 ) )
821 CALL dget10( 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 dtrevc(
'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 )
'DTREVC(R,A)', iinfo, n,
882 CALL dget22(
'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',
'DTREVC',
887 $ dumma( 2 ), n, jtype, ioldsd
893 CALL dtrevc(
'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 )
'DTREVC(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',
'DTREVC', n, jtype,
932 result( 10 ) = ulpinv
933 CALL dtrevc(
'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 )
'DTREVC(L,A)', iinfo, n,
944 CALL dget22(
'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',
'DTREVC', dumma( 4 ),
955 CALL dtrevc(
'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 )
'DTREVC(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',
'DTREVC', n, jtype,
994 result( 11 ) = ulpinv
999 CALL dhsein(
'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 )
'DHSEIN(R)', iinfo, n, jtype,
1014 CALL dget22(
'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',
'DHSEIN',
1020 $ dumma( 2 ), n, jtype, ioldsd
1027 result( 12 ) = ulpinv
1029 SELECT( j ) = .true.
1032 CALL dhsein(
'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 )
'DHSEIN(L)', iinfo, n, jtype,
1047 CALL dget22(
'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',
'DHSEIN',
1053 $ dumma( 4 ), n, jtype, ioldsd
1060 result( 13 ) = ulpinv
1062 CALL dormhr(
'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 )
'DORMHR(R)', iinfo, n, jtype,
1076 CALL dget22(
'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 dormhr(
'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 )
'DORMHR(L)', iinfo, n, jtype,
1101 CALL dget22(
'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 dlafts(
'DHS', n, n, jtype, ntest, result, ioldsd,
1113 $ thresh, nounit, nerrs )
1120 CALL dlasum(
'DHS', nounit, nerrs, ntestt )
1124 9999
FORMAT(
' DCHKHS: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1125 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1126 9998
FORMAT(
' DCHKHS: ', a,
' Eigenvectors from ', a,
' incorrectly ',
1127 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9x,
1128 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
1130 9997
FORMAT(
' DCHKHS: Selected ', a,
' Eigenvectors from ', a,
1131 $
' do not match other eigenvectors ', 9x,
'N=', i6,
1132 $
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dtrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTREVC
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
DLATME
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlatmr(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)
DLATMR
subroutine dget10(M, N, A, LDA, B, LDB, WORK, RESULT)
DGET10
subroutine dhsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO)
DHSEIN
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dchkhs(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)
DCHKHS
subroutine dormhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMHR
subroutine dget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, WI, WORK, RESULT)
DGET22
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS