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 )
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' )
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 )