297 SUBROUTINE cchkhb( 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,
313 INTEGER ISEED( 4 ), KK( * ), NN( * )
314 REAL RESULT( * ), RWORK( * ), SD( * ), SE( * )
315 COMPLEX A( lda, * ), U( ldu, * ), WORK( * )
322 parameter ( czero = ( 0.0e+0, 0.0e+0 ),
323 $ cone = ( 1.0e+0, 0.0e+0 ) )
324 REAL ZERO, ONE, TWO, TEN
325 parameter ( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
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 REAL 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, conjg, max, min,
REAL, 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(
'CCHKHB', -info )
415 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
420 unfl = slamch(
'Safe minimum' )
422 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
424 rtunfl = sqrt( unfl )
425 rtovfl = sqrt( ovfl )
432 DO 190 jsize = 1, nsizes
434 aninv = one /
REAL( 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 claset(
'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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 clatms( 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 clacpy(
' ', k+1, n, a, lda, work, lda )
602 CALL chbtrd(
'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 )
'CHBTRD(U)', iinfo, n,
609 IF( iinfo.LT.0 )
THEN
619 CALL chbt21(
'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 ) = conjg( 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 clacpy(
' ', k+1, n, a, lda, work, lda )
641 CALL chbtrd(
'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 )
'CHBTRD(L)', iinfo, n,
648 IF( iinfo.LT.0 )
THEN
659 CALL chbt21(
'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 )
'CHB'
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 slasum(
'CHB', nounit, nerrs, ntestt )
698 9999
FORMAT(
' CCHKHB: ', 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 SCHK23 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 clatmr(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)
CLATMR
subroutine chbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
CHBTRD
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine chbt21(UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, RWORK, RESULT)
CHBT21
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cchkhb(NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, LWORK, RWORK, RESULT, INFO)
CCHKHB
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM