321 SUBROUTINE zchkhb2stg( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE,
322 $ iseed, thresh, nounit, a, lda, sd, se, d1,
323 $ d2, d3, u, ldu, work, lwork, rwork, result,
332 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
334 DOUBLE PRECISION THRESH
338 INTEGER ISEED( 4 ), KK( * ), NN( * )
339 DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ),
340 $ d1( * ), d2( * ), d3( * )
341 COMPLEX*16 A( lda, * ), U( ldu, * ), WORK( * )
347 COMPLEX*16 CZERO, CONE
348 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
349 $ cone = ( 1.0d+0, 0.0d+0 ) )
350 DOUBLE PRECISION ZERO, ONE, TWO, TEN
351 parameter ( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
353 DOUBLE PRECISION HALF
354 parameter ( half = one / two )
356 parameter ( maxtyp = 15 )
359 LOGICAL BADNN, BADNNB
360 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
361 $ jtype, jwidth, k, kmax, lh, lw, mtypes, n,
362 $ nerrs, nmats, nmax, ntest, ntestt
363 DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
364 $ temp1, temp2, temp3, temp4, ulp, ulpinv, unfl
367 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( maxtyp ),
368 $ kmode( maxtyp ), ktype( maxtyp )
371 DOUBLE PRECISION DLAMCH
379 INTRINSIC abs, dble, dconjg, max, min, sqrt
382 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
383 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
385 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
400 nmax = max( nmax, nn( j ) )
408 kmax = max( kmax, kk( j ) )
412 kmax = min( nmax-1, kmax )
416 IF( nsizes.LT.0 )
THEN
418 ELSE IF( badnn )
THEN
420 ELSE IF( nwdths.LT.0 )
THEN
422 ELSE IF( badnnb )
THEN
424 ELSE IF( ntypes.LT.0 )
THEN
426 ELSE IF( lda.LT.kmax+1 )
THEN
428 ELSE IF( ldu.LT.nmax )
THEN
430 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork )
THEN
435 CALL xerbla(
'ZCHKHBSTG', -info )
441 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
446 unfl = dlamch(
'Safe minimum' )
448 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
450 rtunfl = sqrt( unfl )
451 rtovfl = sqrt( ovfl )
458 DO 190 jsize = 1, nsizes
460 aninv = one / dble( max( 1, n ) )
462 DO 180 jwidth = 1, nwdths
466 k = max( 0, min( n-1, k ) )
468 IF( nsizes.NE.1 )
THEN
469 mtypes = min( maxtyp, ntypes )
471 mtypes = min( maxtyp+1, ntypes )
474 DO 170 jtype = 1, mtypes
475 IF( .NOT.dotype( jtype ) )
481 ioldsd( j ) = iseed( j )
501 IF( mtypes.GT.maxtyp )
504 itype = ktype( jtype )
505 imode = kmode( jtype )
509 GO TO ( 40, 50, 60 )kmagn( jtype )
516 anorm = ( rtovfl*ulp )*aninv
520 anorm = rtunfl*n*ulpinv
525 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
527 IF( jtype.LE.15 )
THEN
530 cond = ulpinv*aninv / ten
537 IF( itype.EQ.1 )
THEN
540 ELSE IF( itype.EQ.2 )
THEN
545 a( k+1, jcol ) = anorm
548 ELSE IF( itype.EQ.4 )
THEN
552 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode,
553 $ cond, anorm, 0, 0,
'Q', a( k+1, 1 ), lda,
556 ELSE IF( itype.EQ.5 )
THEN
560 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode,
561 $ cond, anorm, k, k,
'Q', a, lda, work,
564 ELSE IF( itype.EQ.7 )
THEN
568 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one,
569 $ cone,
'T',
'N', work( n+1 ), 1, one,
570 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
571 $ zero, anorm,
'Q', a( k+1, 1 ), lda,
574 ELSE IF( itype.EQ.8 )
THEN
578 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one,
579 $ cone,
'T',
'N', work( n+1 ), 1, one,
580 $ work( 2*n+1 ), 1, one,
'N', idumma, k, k,
581 $ zero, anorm,
'Q', a, lda, idumma, iinfo )
583 ELSE IF( itype.EQ.9 )
THEN
587 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode,
588 $ cond, anorm, k, k,
'Q', a, lda,
589 $ work( n+1 ), iinfo )
591 ELSE IF( itype.EQ.10 )
THEN
597 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode,
598 $ cond, anorm, 1, 1,
'Q', a( k, 1 ), lda,
601 temp1 = abs( a( k, i ) ) /
602 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
603 IF( temp1.GT.half )
THEN
604 a( k, i ) = half*sqrt( abs( a( k+1,
605 $ i-1 )*a( k+1, i ) ) )
614 IF( iinfo.NE.0 )
THEN
615 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n,
625 CALL zlacpy(
' ', k+1, n, a, lda, work, lda )
628 CALL zhbtrd(
'V',
'U', n, k, work, lda, sd, se, u, ldu,
629 $ work( lda*n+1 ), iinfo )
631 IF( iinfo.NE.0 )
THEN
632 WRITE( nounit, fmt = 9999 )
'ZHBTRD(U)', iinfo, n,
635 IF( iinfo.LT.0 )
THEN
645 CALL zhbt21(
'Upper', n, k, 1, a, lda, sd, se, u, ldu,
646 $ work, rwork, result( 1 ) )
660 CALL dcopy( n, sd, 1, d1, 1 )
662 $
CALL dcopy( n-1, se, 1, rwork, 1 )
664 CALL zsteqr(
'N', n, d1, rwork, work, ldu,
665 $ rwork( n+1 ), iinfo )
666 IF( iinfo.NE.0 )
THEN
667 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n,
670 IF( iinfo.LT.0 )
THEN
683 CALL dlaset(
'Full', n, 1, zero, zero, sd, 1 )
684 CALL dlaset(
'Full', n, 1, zero, zero, se, 1 )
685 CALL zlacpy(
' ', k+1, n, a, lda, u, ldu )
688 CALL zhetrd_hb2st(
'N',
'N',
"U", n, k, u, ldu, sd, se,
689 $ work, lh, work( lh+1 ), lw, iinfo )
693 CALL dcopy( n, sd, 1, d2, 1 )
695 $
CALL dcopy( n-1, se, 1, rwork, 1 )
697 CALL zsteqr(
'N', n, d2, rwork, work, ldu,
698 $ rwork( n+1 ), iinfo )
699 IF( iinfo.NE.0 )
THEN
700 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n,
703 IF( iinfo.LT.0 )
THEN
715 DO 110 jr = 0, min( k, n-jc )
716 a( jr+1, jc ) = dconjg( a( k+1-jr, jc+jr ) )
719 DO 140 jc = n + 1 - k, n
720 DO 130 jr = min( k, n-jc ) + 1, k
727 CALL zlacpy(
' ', k+1, n, a, lda, work, lda )
730 CALL zhbtrd(
'V',
'L', n, k, work, lda, sd, se, u, ldu,
731 $ work( lda*n+1 ), iinfo )
733 IF( iinfo.NE.0 )
THEN
734 WRITE( nounit, fmt = 9999 )
'ZHBTRD(L)', iinfo, n,
737 IF( iinfo.LT.0 )
THEN
748 CALL zhbt21(
'Lower', n, k, 1, a, lda, sd, se, u, ldu,
749 $ work, rwork, result( 3 ) )
756 CALL dlaset(
'Full', n, 1, zero, zero, sd, 1 )
757 CALL dlaset(
'Full', n, 1, zero, zero, se, 1 )
758 CALL zlacpy(
' ', k+1, n, a, lda, u, ldu )
761 CALL zhetrd_hb2st(
'N',
'N',
"L", n, k, u, ldu, sd, se,
762 $ work, lh, work( lh+1 ), lw, iinfo )
766 CALL dcopy( n, sd, 1, d3, 1 )
768 $
CALL dcopy( n-1, se, 1, rwork, 1 )
770 CALL zsteqr(
'N', n, d3, rwork, work, ldu,
771 $ rwork( n+1 ), iinfo )
772 IF( iinfo.NE.0 )
THEN
773 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n,
776 IF( iinfo.LT.0 )
THEN
795 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
796 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
797 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
798 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
801 result(5) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
802 result(6) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
807 ntestt = ntestt + ntest
812 IF( result( jr ).GE.thresh )
THEN
817 IF( nerrs.EQ.0 )
THEN
818 WRITE( nounit, fmt = 9998 )
'ZHB'
819 WRITE( nounit, fmt = 9997 )
820 WRITE( nounit, fmt = 9996 )
821 WRITE( nounit, fmt = 9995 )
'Hermitian'
822 WRITE( nounit, fmt = 9994 )
'unitary',
'*',
823 $
'conjugate transpose', (
'*', j = 1, 6 )
826 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
837 CALL dlasum(
'ZHB', nounit, nerrs, ntestt )
840 9999
FORMAT(
' ZCHKHBSTG: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
841 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
842 9998
FORMAT( / 1x, a3,
843 $
' -- Complex Hermitian Banded Tridiagonal Reduction Routines'
845 9997
FORMAT(
' Matrix types (see DCHK23 for details): ' )
847 9996
FORMAT( /
' Special Matrices:',
848 $ /
' 1=Zero matrix. ',
849 $
' 5=Diagonal: clustered entries.',
850 $ /
' 2=Identity matrix. ',
851 $
' 6=Diagonal: large, evenly spaced.',
852 $ /
' 3=Diagonal: evenly spaced entries. ',
853 $
' 7=Diagonal: small, evenly spaced.',
854 $ /
' 4=Diagonal: geometr. spaced entries.' )
855 9995
FORMAT(
' Dense ', a,
' Banded Matrices:',
856 $ /
' 8=Evenly spaced eigenvals. ',
857 $
' 12=Small, evenly spaced eigenvals.',
858 $ /
' 9=Geometrically spaced eigenvals. ',
859 $
' 13=Matrix with random O(1) entries.',
860 $ /
' 10=Clustered eigenvalues. ',
861 $
' 14=Matrix with large random entries.',
862 $ /
' 11=Large, evenly spaced eigenvals. ',
863 $
' 15=Matrix with small random entries.' )
865 9994
FORMAT( /
' Tests performed: (S is Tridiag, U is ', a,
',',
866 $ / 20x, a,
' means ', a,
'.', /
' UPLO=''U'':',
867 $ /
' 1= | A - U S U', a1,
' | / ( |A| n ulp ) ',
868 $
' 2= | I - U U', a1,
' | / ( n ulp )', /
' UPLO=''L'':',
869 $ /
' 3= | A - U S U', a1,
' | / ( |A| n ulp ) ',
870 $
' 4= | I - U U', a1,
' | / ( n ulp )' /
' Eig check:',
871 $ /
' 5= | D1 - D2',
'',
' | / ( |D1| ulp ) ',
872 $
' 6= | D1 - D3',
'',
' | / ( |D1| ulp ) ' )
873 9993
FORMAT(
' N=', i5,
', K=', i4,
', seed=', 4( i4,
',' ),
' type ',
874 $ i2,
', test(', i2,
')=', g10.3 )
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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
ZSTEQR
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 zchkhb2stg(NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, D2, D3, U, LDU, WORK, LWORK, RWORK, RESULT, INFO)
ZCHKHBSTG
subroutine zhbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
ZHBTRD
subroutine xerbla(SRNAME, INFO)
XERBLA
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 zhbt21(UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, RWORK, RESULT)
ZHBT21
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS