407 SUBROUTINE dchkhs( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
408 $ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
409 $ WI1, WR2, WI2, WR3, WI3, EVECTL, EVECTR,
410 $ EVECTY, EVECTX, UU, TAU, WORK, NWORK, IWORK,
411 $ SELECT, RESULT, INFO )
418 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
419 DOUBLE PRECISION THRESH
422 LOGICAL DOTYPE( * ), SELECT( * )
423 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
424 DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ),
425 $ EVECTR( LDU, * ), EVECTX( LDU, * ),
426 $ evecty( ldu, * ), h( lda, * ), result( 14 ),
427 $ t1( lda, * ), t2( lda, * ), tau( * ),
428 $ u( ldu, * ), uu( ldu, * ), uz( ldu, * ),
429 $ wi1( * ), wi2( * ), wi3( * ), work( * ),
430 $ wr1( * ), wr2( * ), wr3( * ), z( ldu, * )
436 DOUBLE PRECISION ZERO, ONE
437 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
439 PARAMETER ( MAXTYP = 21 )
443 INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
444 $ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
445 $ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
446 DOUBLE PRECISION ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
447 $ rtulpi, rtunfl, temp1, temp2, ulp, ulpinv, unfl
450 CHARACTER ADUMMA( 1 )
451 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
452 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
454 DOUBLE PRECISION DUMMA( 6 )
457 DOUBLE PRECISION DLAMCH
467 INTRINSIC abs, dble, max, min, sqrt
470 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
471 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
473 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
474 $ 1, 5, 5, 5, 4, 3, 1 /
475 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
487 nmax = max( nmax, nn( j ) )
494 IF( nsizes.LT.0 )
THEN
496 ELSE IF( badnn )
THEN
498 ELSE IF( ntypes.LT.0 )
THEN
500 ELSE IF( thresh.LT.zero )
THEN
502 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
504 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax )
THEN
506 ELSE IF( 4*nmax*nmax+2.GT.nwork )
THEN
511 CALL xerbla(
'DCHKHS', -info )
517 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
522 unfl = dlamch(
'Safe minimum' )
523 ovfl = dlamch(
'Overflow' )
525 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
527 rtunfl = sqrt( unfl )
528 rtovfl = sqrt( ovfl )
537 DO 270 jsize = 1, nsizes
542 aninv = one / dble( n1 )
544 IF( nsizes.NE.1 )
THEN
545 mtypes = min( maxtyp, ntypes )
547 mtypes = min( maxtyp+1, ntypes )
550 DO 260 jtype = 1, mtypes
551 IF( .NOT.dotype( jtype ) )
559 ioldsd( j ) = iseed( j )
584 IF( mtypes.GT.maxtyp )
587 itype = ktype( jtype )
588 imode = kmode( jtype )
592 GO TO ( 40, 50, 60 )kmagn( jtype )
599 anorm = ( rtovfl*ulp )*aninv
603 anorm = rtunfl*n*ulpinv
608 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
614 IF( itype.EQ.1 )
THEN
620 ELSE IF( itype.EQ.2 )
THEN
625 a( jcol, jcol ) = anorm
628 ELSE IF( itype.EQ.3 )
THEN
633 a( jcol, jcol ) = anorm
635 $ a( jcol, jcol-1 ) = one
638 ELSE IF( itype.EQ.4 )
THEN
642 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
643 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
646 ELSE IF( itype.EQ.5 )
THEN
650 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
651 $ anorm, n, n,
'N', a, lda, work( n+1 ),
654 ELSE IF( itype.EQ.6 )
THEN
658 IF( kconds( jtype ).EQ.1 )
THEN
660 ELSE IF( kconds( jtype ).EQ.2 )
THEN
667 CALL dlatme( n,
'S', iseed, work, imode, cond, one,
668 $ adumma,
'T',
'T',
'T', work( n+1 ), 4,
669 $ conds, n, n, anorm, a, lda, work( 2*n+1 ),
672 ELSE IF( itype.EQ.7 )
THEN
676 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
677 $
'T',
'N', work( n+1 ), 1, one,
678 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
679 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
681 ELSE IF( itype.EQ.8 )
THEN
685 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
686 $
'T',
'N', work( n+1 ), 1, one,
687 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
688 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
690 ELSE IF( itype.EQ.9 )
THEN
694 CALL dlatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
695 $
'T',
'N', work( n+1 ), 1, one,
696 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
697 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
699 ELSE IF( itype.EQ.10 )
THEN
703 CALL dlatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
704 $
'T',
'N', work( n+1 ), 1, one,
705 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
706 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
713 IF( iinfo.NE.0 )
THEN
714 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
724 CALL dlacpy(
' ', n, n, a, lda, h, lda )
731 CALL dgehrd( n, ilo, ihi, h, lda, work, work( n+1 ),
734 IF( iinfo.NE.0 )
THEN
736 WRITE( nounit, fmt = 9999 )
'DGEHRD', iinfo, n, jtype,
745 u( i, j ) = h( i, j )
746 uu( i, j ) = h( i, j )
750 CALL dcopy( n-1, work, 1, tau, 1 )
751 CALL dorghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
755 CALL dhst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
756 $ nwork, result( 1 ) )
762 CALL dlacpy(
' ', n, n, h, lda, t2, lda )
766 CALL dhseqr(
'E',
'N', n, ilo, ihi, t2, lda, wr3, wi3, uz,
767 $ ldu, work, nwork, iinfo )
768 IF( iinfo.NE.0 )
THEN
769 WRITE( nounit, fmt = 9999 )
'DHSEQR(E)', iinfo, n, jtype,
771 IF( iinfo.LE.n+2 )
THEN
779 CALL dlacpy(
' ', n, n, h, lda, t2, lda )
781 CALL dhseqr(
'S',
'N', n, ilo, ihi, t2, lda, wr2, wi2, uz,
782 $ ldu, work, nwork, iinfo )
783 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
784 WRITE( nounit, fmt = 9999 )
'DHSEQR(S)', iinfo, n, jtype,
793 CALL dlacpy(
' ', n, n, h, lda, t1, lda )
794 CALL dlacpy(
' ', n, n, u, ldu, uz, ldu )
796 CALL dhseqr(
'S',
'V', n, ilo, ihi, t1, lda, wr1, wi1, uz,
797 $ ldu, work, nwork, iinfo )
798 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
799 WRITE( nounit, fmt = 9999 )
'DHSEQR(V)', iinfo, n, jtype,
807 CALL dgemm(
'T',
'N', n, n, n, one, u, ldu, uz, ldu, zero,
814 CALL dhst01( n, ilo, ihi, h, lda, t1, lda, z, ldu, work,
815 $ nwork, result( 3 ) )
820 CALL dhst01( n, ilo, ihi, a, lda, t1, lda, uz, ldu, work,
821 $ nwork, result( 5 ) )
825 CALL dget10( n, n, t2, lda, t1, lda, work, result( 7 ) )
832 temp1 = max( temp1, abs( wr1( j ) )+abs( wi1( j ) ),
833 $ abs( wr2( j ) )+abs( wi2( j ) ) )
834 temp2 = max( temp2, abs( wr1( j )-wr2( j ) )+
835 & abs( wi1( j )-wi2( j ) ) )
838 result( 8 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
853 IF( wi1( j ).EQ.zero )
THEN
854 IF( nselr.LT.max( n / 4, 1 ) )
THEN
858 SELECT( j ) = .false.
862 IF( nselc.LT.max( n / 4, 1 ) )
THEN
865 SELECT( j-1 ) = .false.
867 SELECT( j ) = .false.
868 SELECT( j-1 ) = .false.
875 CALL dtrevc(
'Right',
'All',
SELECT, n, t1, lda, dumma, ldu,
876 $ evectr, ldu, n, in, work, iinfo )
877 IF( iinfo.NE.0 )
THEN
878 WRITE( nounit, fmt = 9999 )
'DTREVC(R,A)', iinfo, n,
886 CALL dget22(
'N',
'N',
'N', n, t1, lda, evectr, ldu, wr1,
887 $ wi1, work, dumma( 1 ) )
888 result( 9 ) = dumma( 1 )
889 IF( dumma( 2 ).GT.thresh )
THEN
890 WRITE( nounit, fmt = 9998 )
'Right',
'DTREVC',
891 $ dumma( 2 ), n, jtype, ioldsd
897 CALL dtrevc(
'Right',
'Some',
SELECT, n, t1, lda, dumma,
898 $ ldu, evectl, ldu, n, in, work, iinfo )
899 IF( iinfo.NE.0 )
THEN
900 WRITE( nounit, fmt = 9999 )
'DTREVC(R,S)', iinfo, n,
909 IF(
SELECT( j ) .AND. wi1( j ).EQ.zero )
THEN
911 IF( evectr( jj, j ).NE.evectl( jj, k ) )
THEN
917 ELSE IF(
SELECT( j ) .AND. wi1( j ).NE.zero )
THEN
919 IF( evectr( jj, j ).NE.evectl( jj, k ) .OR.
920 $ evectr( jj, j+1 ).NE.evectl( jj, k+1 ) )
THEN
930 $
WRITE( nounit, fmt = 9997 )
'Right',
'DTREVC', n, jtype,
936 result( 10 ) = ulpinv
937 CALL dtrevc(
'Left',
'All',
SELECT, n, t1, lda, evectl, ldu,
938 $ dumma, ldu, n, in, work, iinfo )
939 IF( iinfo.NE.0 )
THEN
940 WRITE( nounit, fmt = 9999 )
'DTREVC(L,A)', iinfo, n,
948 CALL dget22(
'Trans',
'N',
'Conj', n, t1, lda, evectl, ldu,
949 $ wr1, wi1, work, dumma( 3 ) )
950 result( 10 ) = dumma( 3 )
951 IF( dumma( 4 ).GT.thresh )
THEN
952 WRITE( nounit, fmt = 9998 )
'Left',
'DTREVC', dumma( 4 ),
959 CALL dtrevc(
'Left',
'Some',
SELECT, n, t1, lda, evectr,
960 $ ldu, dumma, ldu, n, in, work, iinfo )
961 IF( iinfo.NE.0 )
THEN
962 WRITE( nounit, fmt = 9999 )
'DTREVC(L,S)', iinfo, n,
971 IF(
SELECT( j ) .AND. wi1( j ).EQ.zero )
THEN
973 IF( evectl( jj, j ).NE.evectr( jj, k ) )
THEN
979 ELSE IF(
SELECT( j ) .AND. wi1( j ).NE.zero )
THEN
981 IF( evectl( jj, j ).NE.evectr( jj, k ) .OR.
982 $ evectl( jj, j+1 ).NE.evectr( jj, k+1 ) )
THEN
992 $
WRITE( nounit, fmt = 9997 )
'Left',
'DTREVC', n, jtype,
998 result( 11 ) = ulpinv
1000 SELECT( j ) = .true.
1003 CALL dhsein(
'Right',
'Qr',
'Ninitv',
SELECT, n, h, lda,
1004 $ wr3, wi3, dumma, ldu, evectx, ldu, n1, in,
1005 $ work, iwork, iwork, iinfo )
1006 IF( iinfo.NE.0 )
THEN
1007 WRITE( nounit, fmt = 9999 )
'DHSEIN(R)', iinfo, n, jtype,
1018 CALL dget22(
'N',
'N',
'N', n, h, lda, evectx, ldu, wr3,
1019 $ wi3, work, dumma( 1 ) )
1020 IF( dumma( 1 ).LT.ulpinv )
1021 $ result( 11 ) = dumma( 1 )*aninv
1022 IF( dumma( 2 ).GT.thresh )
THEN
1023 WRITE( nounit, fmt = 9998 )
'Right',
'DHSEIN',
1024 $ dumma( 2 ), n, jtype, ioldsd
1031 result( 12 ) = ulpinv
1033 SELECT( j ) = .true.
1036 CALL dhsein(
'Left',
'Qr',
'Ninitv',
SELECT, n, h, lda, wr3,
1037 $ wi3, evecty, ldu, dumma, ldu, n1, in, work,
1038 $ iwork, iwork, iinfo )
1039 IF( iinfo.NE.0 )
THEN
1040 WRITE( nounit, fmt = 9999 )
'DHSEIN(L)', iinfo, n, jtype,
1051 CALL dget22(
'C',
'N',
'C', n, h, lda, evecty, ldu, wr3,
1052 $ wi3, work, dumma( 3 ) )
1053 IF( dumma( 3 ).LT.ulpinv )
1054 $ result( 12 ) = dumma( 3 )*aninv
1055 IF( dumma( 4 ).GT.thresh )
THEN
1056 WRITE( nounit, fmt = 9998 )
'Left',
'DHSEIN',
1057 $ dumma( 4 ), n, jtype, ioldsd
1064 result( 13 ) = ulpinv
1066 CALL dormhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1067 $ ldu, tau, evectx, ldu, work, nwork, iinfo )
1068 IF( iinfo.NE.0 )
THEN
1069 WRITE( nounit, fmt = 9999 )
'DORMHR(R)', iinfo, n, jtype,
1080 CALL dget22(
'N',
'N',
'N', n, a, lda, evectx, ldu, wr3,
1081 $ wi3, work, dumma( 1 ) )
1082 IF( dumma( 1 ).LT.ulpinv )
1083 $ result( 13 ) = dumma( 1 )*aninv
1089 result( 14 ) = ulpinv
1091 CALL dormhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1092 $ ldu, tau, evecty, ldu, work, nwork, iinfo )
1093 IF( iinfo.NE.0 )
THEN
1094 WRITE( nounit, fmt = 9999 )
'DORMHR(L)', iinfo, n, jtype,
1105 CALL dget22(
'C',
'N',
'C', n, a, lda, evecty, ldu, wr3,
1106 $ wi3, work, dumma( 3 ) )
1107 IF( dumma( 3 ).LT.ulpinv )
1108 $ result( 14 ) = dumma( 3 )*aninv
1115 ntestt = ntestt + ntest
1116 CALL dlafts(
'DHS', n, n, jtype, ntest, result, ioldsd,
1117 $ thresh, nounit, nerrs )
1124 CALL dlasum(
'DHS', nounit, nerrs, ntestt )
1128 9999
FORMAT(
' DCHKHS: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1129 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1130 9998
FORMAT(
' DCHKHS: ', a,
' Eigenvectors from ', a,
' incorrectly ',
1131 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9x,
1132 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
1134 9997
FORMAT(
' DCHKHS: Selected ', a,
' Eigenvectors from ', a,
1135 $
' do not match other eigenvectors ', 9x,
'N=', i6,
1136 $
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
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 xerbla(SRNAME, INFO)
XERBLA
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, WI, WORK, RESULT)
DGET22
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
subroutine dchkhs(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1, WI1, WR2, WI2, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX, UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT, INFO)
DCHKHS
subroutine dget10(M, N, A, LDA, B, LDB, WORK, RESULT)
DGET10
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 dlatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
DLATME
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dhsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO)
DHSEIN
subroutine dtrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTREVC
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
subroutine dormhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMHR
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR