409 SUBROUTINE zchkhs( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
410 $ nounit, a, lda, h, t1, t2, u, ldu, z, uz, w1,
411 $ w3, evectl, evectr, evecty, evectx, uu, tau,
412 $ work, nwork, rwork, iwork,
SELECT, result,
421 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
422 DOUBLE PRECISION THRESH
425 LOGICAL DOTYPE( * ), SELECT( * )
426 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
427 DOUBLE PRECISION RESULT( 14 ), RWORK( * )
428 COMPLEX*16 A( lda, * ), EVECTL( ldu, * ),
429 $ evectr( ldu, * ), evectx( ldu, * ),
430 $ evecty( ldu, * ), h( lda, * ), t1( lda, * ),
431 $ t2( lda, * ), tau( * ), u( ldu, * ),
432 $ uu( ldu, * ), uz( ldu, * ), w1( * ), w3( * ),
433 $ work( * ), z( ldu, * )
439 DOUBLE PRECISION ZERO, ONE
440 parameter( zero = 0.0d+0, one = 1.0d+0 )
441 COMPLEX*16 CZERO, CONE
442 parameter( czero = ( 0.0d+0, 0.0d+0 ),
443 $ cone = ( 1.0d+0, 0.0d+0 ) )
445 parameter( maxtyp = 21 )
449 INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
450 $ jj, jsize, jtype, k, mtypes, n, n1, nerrs,
451 $ nmats, nmax, ntest, ntestt
452 DOUBLE PRECISION ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
453 $ rtulpi, rtunfl, temp1, temp2, ulp, ulpinv, unfl
456 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
457 $ kmagn( maxtyp ), kmode( maxtyp ),
459 DOUBLE PRECISION DUMMA( 4 )
460 COMPLEX*16 CDUMMA( 4 )
463 DOUBLE PRECISION DLAMCH
473 INTRINSIC abs, dble, max, min, sqrt
476 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
477 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
479 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
480 $ 1, 5, 5, 5, 4, 3, 1 /
481 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
493 nmax = max( nmax, nn( j ) )
500 IF( nsizes.LT.0 )
THEN
502 ELSE IF( badnn )
THEN
504 ELSE IF( ntypes.LT.0 )
THEN
506 ELSE IF( thresh.LT.zero )
THEN
508 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
510 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax )
THEN
512 ELSE IF( 4*nmax*nmax+2.GT.nwork )
THEN
517 CALL
xerbla(
'ZCHKHS', -info )
523 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
528 unfl = dlamch(
'Safe minimum' )
529 ovfl = dlamch(
'Overflow' )
531 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
533 rtunfl = sqrt( unfl )
534 rtovfl = sqrt( ovfl )
543 DO 260 jsize = 1, nsizes
548 aninv = one / dble( n1 )
550 IF( nsizes.NE.1 )
THEN
551 mtypes = min( maxtyp, ntypes )
553 mtypes = min( maxtyp+1, ntypes )
556 DO 250 jtype = 1, mtypes
557 IF( .NOT.dotype( jtype ) )
565 ioldsd( j ) = iseed( j )
590 IF( mtypes.GT.maxtyp )
593 itype = ktype( jtype )
594 imode = kmode( jtype )
598 go to( 40, 50, 60 )kmagn( jtype )
605 anorm = ( rtovfl*ulp )*aninv
609 anorm = rtunfl*n*ulpinv
614 CALL
zlaset(
'Full', lda, n, czero, czero, a, lda )
620 IF( itype.EQ.1 )
THEN
625 ELSE IF( itype.EQ.2 )
THEN
630 a( jcol, jcol ) = anorm
633 ELSE IF( itype.EQ.3 )
THEN
638 a( jcol, jcol ) = anorm
640 $ a( jcol, jcol-1 ) = one
643 ELSE IF( itype.EQ.4 )
THEN
647 CALL
zlatmr( n, n,
'D', iseed,
'N', work, imode, cond,
648 $ cone,
'T',
'N', work( n+1 ), 1, one,
649 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
650 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
652 ELSE IF( itype.EQ.5 )
THEN
656 CALL
zlatms( n, n,
'D', iseed,
'H', rwork, imode, cond,
657 $ anorm, n, n,
'N', a, lda, work, iinfo )
659 ELSE IF( itype.EQ.6 )
THEN
663 IF( kconds( jtype ).EQ.1 )
THEN
665 ELSE IF( kconds( jtype ).EQ.2 )
THEN
671 CALL
zlatme( n,
'D', iseed, work, imode, cond, cone,
672 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
673 $ a, lda, work( n+1 ), iinfo )
675 ELSE IF( itype.EQ.7 )
THEN
679 CALL
zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
680 $
'T',
'N', work( n+1 ), 1, one,
681 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
682 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
684 ELSE IF( itype.EQ.8 )
THEN
688 CALL
zlatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
689 $
'T',
'N', work( n+1 ), 1, one,
690 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
691 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
693 ELSE IF( itype.EQ.9 )
THEN
697 CALL
zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
698 $
'T',
'N', work( n+1 ), 1, one,
699 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
700 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
702 ELSE IF( itype.EQ.10 )
THEN
706 CALL
zlatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
707 $
'T',
'N', work( n+1 ), 1, one,
708 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
709 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
716 IF( iinfo.NE.0 )
THEN
717 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
727 CALL
zlacpy(
' ', n, n, a, lda, h, lda )
733 CALL
zgehrd( n, ilo, ihi, h, lda, work, work( n+1 ),
736 IF( iinfo.NE.0 )
THEN
738 WRITE( nounit, fmt = 9999 )
'ZGEHRD', iinfo, n, jtype,
747 u( i, j ) = h( i, j )
748 uu( i, j ) = h( i, j )
752 CALL
zcopy( n-1, work, 1, tau, 1 )
753 CALL
zunghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
757 CALL
zhst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
758 $ nwork, rwork, result( 1 ) )
764 CALL
zlacpy(
' ', n, n, h, lda, t2, lda )
768 CALL
zhseqr(
'E',
'N', n, ilo, ihi, t2, lda, w3, uz, ldu,
769 $ work, nwork, iinfo )
770 IF( iinfo.NE.0 )
THEN
771 WRITE( nounit, fmt = 9999 )
'ZHSEQR(E)', iinfo, n, jtype,
773 IF( iinfo.LE.n+2 )
THEN
781 CALL
zlacpy(
' ', n, n, h, lda, t2, lda )
783 CALL
zhseqr(
'S',
'N', n, ilo, ihi, t2, lda, w1, uz, ldu,
784 $ work, nwork, iinfo )
785 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
786 WRITE( nounit, fmt = 9999 )
'ZHSEQR(S)', iinfo, n, jtype,
794 CALL
zlacpy(
' ', n, n, h, lda, t1, lda )
795 CALL
zlacpy(
' ', n, n, u, ldu, uz, ldu )
797 CALL
zhseqr(
'S',
'V', n, ilo, ihi, t1, lda, w1, uz, ldu,
798 $ work, nwork, iinfo )
799 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
800 WRITE( nounit, fmt = 9999 )
'ZHSEQR(V)', iinfo, n, jtype,
808 CALL
zgemm(
'C',
'N', n, n, n, cone, u, ldu, uz, ldu, czero,
815 CALL
zhst01( n, ilo, ihi, h, lda, t1, lda, z, ldu, work,
816 $ nwork, rwork, result( 3 ) )
821 CALL
zhst01( n, ilo, ihi, a, lda, t1, lda, uz, ldu, work,
822 $ nwork, rwork, result( 5 ) )
826 CALL
zget10( n, n, t2, lda, t1, lda, work, rwork,
834 temp1 = max( temp1, abs( w1( j ) ), abs( w3( j ) ) )
835 temp2 = max( temp2, abs( w1( j )-w3( j ) ) )
838 result( 8 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
850 SELECT( j ) = .false.
855 CALL
ztrevc(
'Right',
'All',
SELECT, n, t1, lda, cdumma,
856 $ ldu, evectr, ldu, n, in, work, rwork, iinfo )
857 IF( iinfo.NE.0 )
THEN
858 WRITE( nounit, fmt = 9999 )
'ZTREVC(R,A)', iinfo, n,
866 CALL
zget22(
'N',
'N',
'N', n, t1, lda, evectr, ldu, w1,
867 $ work, rwork, dumma( 1 ) )
868 result( 9 ) = dumma( 1 )
869 IF( dumma( 2 ).GT.thresh )
THEN
870 WRITE( nounit, fmt = 9998 )
'Right',
'ZTREVC',
871 $ dumma( 2 ), n, jtype, ioldsd
877 CALL
ztrevc(
'Right',
'Some',
SELECT, n, t1, lda, cdumma,
878 $ ldu, evectl, ldu, n, in, work, rwork, iinfo )
879 IF( iinfo.NE.0 )
THEN
880 WRITE( nounit, fmt = 9999 )
'ZTREVC(R,S)', iinfo, n,
889 IF(
SELECT( j ) )
THEN
891 IF( evectr( jj, j ).NE.evectl( jj, k ) )
THEN
901 $
WRITE( nounit, fmt = 9997 )
'Right',
'ZTREVC', n, jtype,
907 result( 10 ) = ulpinv
908 CALL
ztrevc(
'Left',
'All',
SELECT, n, t1, lda, evectl, ldu,
909 $ cdumma, ldu, n, in, work, rwork, iinfo )
910 IF( iinfo.NE.0 )
THEN
911 WRITE( nounit, fmt = 9999 )
'ZTREVC(L,A)', iinfo, n,
919 CALL
zget22(
'C',
'N',
'C', n, t1, lda, evectl, ldu, w1,
920 $ work, rwork, dumma( 3 ) )
921 result( 10 ) = dumma( 3 )
922 IF( dumma( 4 ).GT.thresh )
THEN
923 WRITE( nounit, fmt = 9998 )
'Left',
'ZTREVC', dumma( 4 ),
930 CALL
ztrevc(
'Left',
'Some',
SELECT, n, t1, lda, evectr,
931 $ ldu, cdumma, ldu, n, in, work, rwork, iinfo )
932 IF( iinfo.NE.0 )
THEN
933 WRITE( nounit, fmt = 9999 )
'ZTREVC(L,S)', iinfo, n,
942 IF(
SELECT( j ) )
THEN
944 IF( evectl( jj, j ).NE.evectr( jj, k ) )
THEN
954 $
WRITE( nounit, fmt = 9997 )
'Left',
'ZTREVC', n, jtype,
960 result( 11 ) = ulpinv
965 CALL
zhsein(
'Right',
'Qr',
'Ninitv',
SELECT, n, h, lda, w3,
966 $ cdumma, ldu, evectx, ldu, n1, in, work, rwork,
967 $ iwork, iwork, iinfo )
968 IF( iinfo.NE.0 )
THEN
969 WRITE( nounit, fmt = 9999 )
'ZHSEIN(R)', iinfo, n, jtype,
980 CALL
zget22(
'N',
'N',
'N', n, h, lda, evectx, ldu, w3,
981 $ work, rwork, dumma( 1 ) )
982 IF( dumma( 1 ).LT.ulpinv )
983 $ result( 11 ) = dumma( 1 )*aninv
984 IF( dumma( 2 ).GT.thresh )
THEN
985 WRITE( nounit, fmt = 9998 )
'Right',
'ZHSEIN',
986 $ dumma( 2 ), n, jtype, ioldsd
993 result( 12 ) = ulpinv
998 CALL
zhsein(
'Left',
'Qr',
'Ninitv',
SELECT, n, h, lda, w3,
999 $ evecty, ldu, cdumma, ldu, n1, in, work, rwork,
1000 $ iwork, iwork, iinfo )
1001 IF( iinfo.NE.0 )
THEN
1002 WRITE( nounit, fmt = 9999 )
'ZHSEIN(L)', iinfo, n, jtype,
1013 CALL
zget22(
'C',
'N',
'C', n, h, lda, evecty, ldu, w3,
1014 $ work, rwork, dumma( 3 ) )
1015 IF( dumma( 3 ).LT.ulpinv )
1016 $ result( 12 ) = dumma( 3 )*aninv
1017 IF( dumma( 4 ).GT.thresh )
THEN
1018 WRITE( nounit, fmt = 9998 )
'Left',
'ZHSEIN',
1019 $ dumma( 4 ), n, jtype, ioldsd
1026 result( 13 ) = ulpinv
1028 CALL
zunmhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1029 $ ldu, tau, evectx, ldu, work, nwork, iinfo )
1030 IF( iinfo.NE.0 )
THEN
1031 WRITE( nounit, fmt = 9999 )
'ZUNMHR(L)', iinfo, n, jtype,
1042 CALL
zget22(
'N',
'N',
'N', n, a, lda, evectx, ldu, w3,
1043 $ work, rwork, dumma( 1 ) )
1044 IF( dumma( 1 ).LT.ulpinv )
1045 $ result( 13 ) = dumma( 1 )*aninv
1051 result( 14 ) = ulpinv
1053 CALL
zunmhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1054 $ ldu, tau, evecty, ldu, work, nwork, iinfo )
1055 IF( iinfo.NE.0 )
THEN
1056 WRITE( nounit, fmt = 9999 )
'ZUNMHR(L)', iinfo, n, jtype,
1067 CALL
zget22(
'C',
'N',
'C', n, a, lda, evecty, ldu, w3,
1068 $ work, rwork, dumma( 3 ) )
1069 IF( dumma( 3 ).LT.ulpinv )
1070 $ result( 14 ) = dumma( 3 )*aninv
1077 ntestt = ntestt + ntest
1078 CALL
dlafts(
'ZHS', n, n, jtype, ntest, result, ioldsd,
1079 $ thresh, nounit, nerrs )
1086 CALL
dlasum(
'ZHS', nounit, nerrs, ntestt )
1090 9999
FORMAT(
' ZCHKHS: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1091 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1092 9998
FORMAT(
' ZCHKHS: ', a,
' Eigenvectors from ', a,
' incorrectly ',
1093 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9x,
1094 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
1096 9997
FORMAT(
' ZCHKHS: Selected ', a,
' Eigenvectors from ', a,
1097 $
' do not match other eigenvectors ', 9x,
'N=', i6,
1098 $
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine ztrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
ZTREVC
subroutine zhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
ZHSEQR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
ZGEHRD
subroutine zchkhs(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, W1, W3, EVECTL, EVECTR, EVECTY, EVECTX, UU, TAU, WORK, NWORK, RWORK, IWORK, SELECT, RESULT, INFO)
ZCHKHS
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zunghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGHR
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
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 dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine zget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
ZGET22
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 zget10(M, N, A, LDA, B, LDB, WORK, RWORK, RESULT)
ZGET10
subroutine zhsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO)
ZHSEIN
subroutine zunmhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMHR
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
ZHST01
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS