321 SUBROUTINE cchkhb2stg( 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,
338 INTEGER ISEED( 4 ), KK( * ), NN( * )
339 REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ),
340 $ d1( * ), d2( * ), d3( * )
341 COMPLEX A( lda, * ), U( ldu, * ), WORK( * )
348 parameter ( czero = ( 0.0e+0, 0.0e+0 ),
349 $ cone = ( 1.0e+0, 0.0e+0 ) )
350 REAL ZERO, ONE, TWO, TEN
351 parameter ( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
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 REAL 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 )
379 INTRINSIC abs,
REAL, CONJG, 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(
'CCHKHBSTG', -info )
441 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
446 unfl = slamch(
'Safe minimum' )
448 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
450 rtunfl = sqrt( unfl )
451 rtovfl = sqrt( ovfl )
458 DO 190 jsize = 1, nsizes
460 aninv = one /
REAL( 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 claset(
'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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 clatms( 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 clacpy(
' ', k+1, n, a, lda, work, lda )
628 CALL chbtrd(
'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 )
'CHBTRD(U)', iinfo, n,
635 IF( iinfo.LT.0 )
THEN
645 CALL chbt21(
'Upper', n, k, 1, a, lda, sd, se, u, ldu,
646 $ work, rwork, result( 1 ) )
660 CALL scopy( n, sd, 1, d1, 1 )
662 $
CALL scopy( n-1, se, 1, rwork, 1 )
664 CALL csteqr(
'N', n, d1, rwork, work, ldu,
665 $ rwork( n+1 ), iinfo )
666 IF( iinfo.NE.0 )
THEN
667 WRITE( nounit, fmt = 9999 )
'CSTEQR(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 clacpy(
' ', k+1, n, a, lda, u, ldu )
688 CALL chetrd_hb2st(
'N',
'N',
"U", n, k, u, ldu, sd, se,
689 $ work, lh, work( lh+1 ), lw, iinfo )
693 CALL scopy( n, sd, 1, d2, 1 )
695 $
CALL scopy( n-1, se, 1, rwork, 1 )
697 CALL csteqr(
'N', n, d2, rwork, work, ldu,
698 $ rwork( n+1 ), iinfo )
699 IF( iinfo.NE.0 )
THEN
700 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n,
703 IF( iinfo.LT.0 )
THEN
715 DO 110 jr = 0, min( k, n-jc )
716 a( jr+1, jc ) = conjg( 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 clacpy(
' ', k+1, n, a, lda, work, lda )
730 CALL chbtrd(
'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 )
'CHBTRD(L)', iinfo, n,
737 IF( iinfo.LT.0 )
THEN
748 CALL chbt21(
'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 clacpy(
' ', k+1, n, a, lda, u, ldu )
761 CALL chetrd_hb2st(
'N',
'N',
"L", n, k, u, ldu, sd, se,
762 $ work, lh, work( lh+1 ), lw, iinfo )
766 CALL scopy( n, sd, 1, d3, 1 )
768 $
CALL scopy( n-1, se, 1, rwork, 1 )
770 CALL csteqr(
'N', n, d3, rwork, work, ldu,
771 $ rwork( n+1 ), iinfo )
772 IF( iinfo.NE.0 )
THEN
773 WRITE( nounit, fmt = 9999 )
'CSTEQR(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 )
'CHB'
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 slasum(
'CHB', nounit, nerrs, ntestt )
840 9999
FORMAT(
' CCHKHBSTG: ', 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 SCHK23 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 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 cchkhb2stg(NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, D2, D3, U, LDU, WORK, LWORK, RWORK, RESULT, INFO)
CCHKHBSTG
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 csteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CSTEQR
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 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 slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY