297 SUBROUTINE zchkhb( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
298 $ thresh, nounit, a, lda, sd, se, u, ldu, work,
299 $ lwork, rwork, result, info )
307 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
309 DOUBLE PRECISION THRESH
313 INTEGER ISEED( 4 ), KK( * ), NN( * )
314 DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * )
315 COMPLEX*16 A( lda, * ), U( ldu, * ), WORK( * )
321 COMPLEX*16 CZERO, CONE
322 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
323 $ cone = ( 1.0d+0, 0.0d+0 ) )
324 DOUBLE PRECISION ZERO, ONE, TWO, TEN
325 parameter ( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
327 DOUBLE PRECISION HALF
328 parameter ( half = one / two )
330 parameter ( maxtyp = 15 )
333 LOGICAL BADNN, BADNNB
334 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
335 $ jtype, jwidth, k, kmax, mtypes, n, nerrs,
336 $ nmats, nmax, ntest, ntestt
337 DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
338 $ temp1, ulp, ulpinv, unfl
341 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( maxtyp ),
342 $ kmode( maxtyp ), ktype( maxtyp )
345 DOUBLE PRECISION DLAMCH
353 INTRINSIC abs, dble, dconjg, max, min, sqrt
356 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
357 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
359 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
374 nmax = max( nmax, nn( j ) )
382 kmax = max( kmax, kk( j ) )
386 kmax = min( nmax-1, kmax )
390 IF( nsizes.LT.0 )
THEN
392 ELSE IF( badnn )
THEN
394 ELSE IF( nwdths.LT.0 )
THEN
396 ELSE IF( badnnb )
THEN
398 ELSE IF( ntypes.LT.0 )
THEN
400 ELSE IF( lda.LT.kmax+1 )
THEN
402 ELSE IF( ldu.LT.nmax )
THEN
404 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork )
THEN
409 CALL xerbla(
'ZCHKHB', -info )
415 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
420 unfl = dlamch(
'Safe minimum' )
422 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
424 rtunfl = sqrt( unfl )
425 rtovfl = sqrt( ovfl )
432 DO 190 jsize = 1, nsizes
434 aninv = one / dble( max( 1, n ) )
436 DO 180 jwidth = 1, nwdths
440 k = max( 0, min( n-1, k ) )
442 IF( nsizes.NE.1 )
THEN
443 mtypes = min( maxtyp, ntypes )
445 mtypes = min( maxtyp+1, ntypes )
448 DO 170 jtype = 1, mtypes
449 IF( .NOT.dotype( jtype ) )
455 ioldsd( j ) = iseed( j )
475 IF( mtypes.GT.maxtyp )
478 itype = ktype( jtype )
479 imode = kmode( jtype )
483 GO TO ( 40, 50, 60 )kmagn( jtype )
490 anorm = ( rtovfl*ulp )*aninv
494 anorm = rtunfl*n*ulpinv
499 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
501 IF( jtype.LE.15 )
THEN
504 cond = ulpinv*aninv / ten
511 IF( itype.EQ.1 )
THEN
514 ELSE IF( itype.EQ.2 )
THEN
519 a( k+1, jcol ) = anorm
522 ELSE IF( itype.EQ.4 )
THEN
526 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode,
527 $ cond, anorm, 0, 0,
'Q', a( k+1, 1 ), lda,
530 ELSE IF( itype.EQ.5 )
THEN
534 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode,
535 $ cond, anorm, k, k,
'Q', a, lda, work,
538 ELSE IF( itype.EQ.7 )
THEN
542 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one,
543 $ cone,
'T',
'N', work( n+1 ), 1, one,
544 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
545 $ zero, anorm,
'Q', a( k+1, 1 ), lda,
548 ELSE IF( itype.EQ.8 )
THEN
552 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one,
553 $ cone,
'T',
'N', work( n+1 ), 1, one,
554 $ work( 2*n+1 ), 1, one,
'N', idumma, k, k,
555 $ zero, anorm,
'Q', a, lda, idumma, iinfo )
557 ELSE IF( itype.EQ.9 )
THEN
561 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode,
562 $ cond, anorm, k, k,
'Q', a, lda,
563 $ work( n+1 ), iinfo )
565 ELSE IF( itype.EQ.10 )
THEN
571 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode,
572 $ cond, anorm, 1, 1,
'Q', a( k, 1 ), lda,
575 temp1 = abs( a( k, i ) ) /
576 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
577 IF( temp1.GT.half )
THEN
578 a( k, i ) = half*sqrt( abs( a( k+1,
579 $ i-1 )*a( k+1, i ) ) )
588 IF( iinfo.NE.0 )
THEN
589 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n,
599 CALL zlacpy(
' ', k+1, n, a, lda, work, lda )
602 CALL zhbtrd(
'V',
'U', n, k, work, lda, sd, se, u, ldu,
603 $ work( lda*n+1 ), iinfo )
605 IF( iinfo.NE.0 )
THEN
606 WRITE( nounit, fmt = 9999 )
'ZHBTRD(U)', iinfo, n,
609 IF( iinfo.LT.0 )
THEN
619 CALL zhbt21(
'Upper', n, k, 1, a, lda, sd, se, u, ldu,
620 $ work, rwork, result( 1 ) )
626 DO 110 jr = 0, min( k, n-jc )
627 a( jr+1, jc ) = dconjg( a( k+1-jr, jc+jr ) )
630 DO 140 jc = n + 1 - k, n
631 DO 130 jr = min( k, n-jc ) + 1, k
638 CALL zlacpy(
' ', k+1, n, a, lda, work, lda )
641 CALL zhbtrd(
'V',
'L', n, k, work, lda, sd, se, u, ldu,
642 $ work( lda*n+1 ), iinfo )
644 IF( iinfo.NE.0 )
THEN
645 WRITE( nounit, fmt = 9999 )
'ZHBTRD(L)', iinfo, n,
648 IF( iinfo.LT.0 )
THEN
659 CALL zhbt21(
'Lower', n, k, 1, a, lda, sd, se, u, ldu,
660 $ work, rwork, result( 3 ) )
665 ntestt = ntestt + ntest
670 IF( result( jr ).GE.thresh )
THEN
675 IF( nerrs.EQ.0 )
THEN
676 WRITE( nounit, fmt = 9998 )
'ZHB'
677 WRITE( nounit, fmt = 9997 )
678 WRITE( nounit, fmt = 9996 )
679 WRITE( nounit, fmt = 9995 )
'Hermitian'
680 WRITE( nounit, fmt = 9994 )
'unitary',
'*',
681 $
'conjugate transpose', (
'*', j = 1, 4 )
684 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
695 CALL dlasum(
'ZHB', nounit, nerrs, ntestt )
698 9999
FORMAT(
' ZCHKHB: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
699 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
700 9998
FORMAT( / 1x, a3,
701 $
' -- Complex Hermitian Banded Tridiagonal Reduction Routines'
703 9997
FORMAT(
' Matrix types (see DCHK23 for details): ' )
705 9996
FORMAT( /
' Special Matrices:',
706 $ /
' 1=Zero matrix. ',
707 $
' 5=Diagonal: clustered entries.',
708 $ /
' 2=Identity matrix. ',
709 $
' 6=Diagonal: large, evenly spaced.',
710 $ /
' 3=Diagonal: evenly spaced entries. ',
711 $
' 7=Diagonal: small, evenly spaced.',
712 $ /
' 4=Diagonal: geometr. spaced entries.' )
713 9995
FORMAT(
' Dense ', a,
' Banded Matrices:',
714 $ /
' 8=Evenly spaced eigenvals. ',
715 $
' 12=Small, evenly spaced eigenvals.',
716 $ /
' 9=Geometrically spaced eigenvals. ',
717 $
' 13=Matrix with random O(1) entries.',
718 $ /
' 10=Clustered eigenvalues. ',
719 $
' 14=Matrix with large random entries.',
720 $ /
' 11=Large, evenly spaced eigenvals. ',
721 $
' 15=Matrix with small random entries.' )
723 9994
FORMAT( /
' Tests performed: (S is Tridiag, U is ', a,
',',
724 $ / 20x, a,
' means ', a,
'.', /
' UPLO=''U'':',
725 $ /
' 1= | A - U S U', a1,
' | / ( |A| n ulp ) ',
726 $
' 2= | I - U U', a1,
' | / ( n ulp )', /
' UPLO=''L'':',
727 $ /
' 3= | A - U S U', a1,
' | / ( |A| n ulp ) ',
728 $
' 4= | I - U U', a1,
' | / ( n ulp )' )
729 9993
FORMAT(
' N=', i5,
', K=', i4,
', seed=', 4( i4,
',' ),
' type ',
730 $ 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 zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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
subroutine zchkhb(NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, LWORK, RWORK, RESULT, INFO)
ZCHKHB