337 SUBROUTINE cchkhb2stg( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE,
338 $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1,
339 $ D2, D3, U, LDU, WORK, LWORK, RWORK, RESULT,
347 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
353 INTEGER ISEED( 4 ), KK( * ), NN( * )
354 REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ),
355 $ d1( * ), d2( * ), d3( * )
356 COMPLEX A( LDA, * ), U( LDU, * ), WORK( * )
363 PARAMETER ( CZERO = ( 0.0e+0, 0.0e+0 ),
364 $ cone = ( 1.0e+0, 0.0e+0 ) )
365 REAL ZERO, ONE, TWO, TEN
366 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
369 parameter( half = one / two )
371 parameter( maxtyp = 15 )
374 LOGICAL BADNN, BADNNB
375 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
376 $ JTYPE, JWIDTH, K, KMAX, LH, LW, MTYPES, N,
377 $ nerrs, nmats, nmax, ntest, ntestt
378 REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
379 $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL
382 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
383 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
394 INTRINSIC abs, real, conjg, max, min, sqrt
397 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
398 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
400 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
415 nmax = max( nmax, nn( j ) )
423 kmax = max( kmax, kk( j ) )
427 kmax = min( nmax-1, kmax )
431 IF( nsizes.LT.0 )
THEN
433 ELSE IF( badnn )
THEN
435 ELSE IF( nwdths.LT.0 )
THEN
437 ELSE IF( badnnb )
THEN
439 ELSE IF( ntypes.LT.0 )
THEN
441 ELSE IF( lda.LT.kmax+1 )
THEN
443 ELSE IF( ldu.LT.nmax )
THEN
445 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork )
THEN
450 CALL xerbla(
'CCHKHB2STG', -info )
456 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
461 unfl = slamch(
'Safe minimum' )
463 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
465 rtunfl = sqrt( unfl )
466 rtovfl = sqrt( ovfl )
473 DO 190 jsize = 1, nsizes
475 aninv = one / real( max( 1, n ) )
477 DO 180 jwidth = 1, nwdths
481 k = max( 0, min( n-1, k ) )
483 IF( nsizes.NE.1 )
THEN
484 mtypes = min( maxtyp, ntypes )
486 mtypes = min( maxtyp+1, ntypes )
489 DO 170 jtype = 1, mtypes
490 IF( .NOT.dotype( jtype ) )
496 ioldsd( j ) = iseed( j )
516 IF( mtypes.GT.maxtyp )
519 itype = ktype( jtype )
520 imode = kmode( jtype )
524 GO TO ( 40, 50, 60 )kmagn( jtype )
531 anorm = ( rtovfl*ulp )*aninv
535 anorm = rtunfl*n*ulpinv
540 CALL claset(
'Full', lda, n, czero, czero, a, lda )
542 IF( jtype.LE.15 )
THEN
545 cond = ulpinv*aninv / ten
552 IF( itype.EQ.1 )
THEN
555 ELSE IF( itype.EQ.2 )
THEN
560 a( k+1, jcol ) = anorm
563 ELSE IF( itype.EQ.4 )
THEN
567 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode,
568 $ cond, anorm, 0, 0,
'Q', a( k+1, 1 ), lda,
571 ELSE IF( itype.EQ.5 )
THEN
575 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode,
576 $ cond, anorm, k, k,
'Q', a, lda, work,
579 ELSE IF( itype.EQ.7 )
THEN
583 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one,
584 $ cone,
'T',
'N', work( n+1 ), 1, one,
585 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
586 $ zero, anorm,
'Q', a( k+1, 1 ), lda,
589 ELSE IF( itype.EQ.8 )
THEN
593 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one,
594 $ cone,
'T',
'N', work( n+1 ), 1, one,
595 $ work( 2*n+1 ), 1, one,
'N', idumma, k, k,
596 $ zero, anorm,
'Q', a, lda, idumma, iinfo )
598 ELSE IF( itype.EQ.9 )
THEN
602 CALL clatms( n, n,
'S', iseed,
'P', rwork, imode,
603 $ cond, anorm, k, k,
'Q', a, lda,
604 $ work( n+1 ), iinfo )
606 ELSE IF( itype.EQ.10 )
THEN
612 CALL clatms( n, n,
'S', iseed,
'P', rwork, imode,
613 $ cond, anorm, 1, 1,
'Q', a( k, 1 ), lda,
616 temp1 = abs( a( k, i ) ) /
617 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
618 IF( temp1.GT.half )
THEN
619 a( k, i ) = half*sqrt( abs( a( k+1,
620 $ i-1 )*a( k+1, i ) ) )
629 IF( iinfo.NE.0 )
THEN
630 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n,
640 CALL clacpy(
' ', k+1, n, a, lda, work, lda )
643 CALL chbtrd(
'V',
'U', n, k, work, lda, sd, se, u, ldu,
644 $ work( lda*n+1 ), iinfo )
646 IF( iinfo.NE.0 )
THEN
647 WRITE( nounit, fmt = 9999 )
'CHBTRD(U)', iinfo, n,
650 IF( iinfo.LT.0 )
THEN
660 CALL chbt21(
'Upper', n, k, 1, a, lda, sd, se, u, ldu,
661 $ work, rwork, result( 1 ) )
675 CALL scopy( n, sd, 1, d1, 1 )
677 $
CALL scopy( n-1, se, 1, rwork, 1 )
679 CALL csteqr(
'N', n, d1, rwork, work, ldu,
680 $ rwork( n+1 ), iinfo )
681 IF( iinfo.NE.0 )
THEN
682 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n,
685 IF( iinfo.LT.0 )
THEN
698 CALL slaset(
'Full', n, 1, zero, zero, sd, n )
699 CALL slaset(
'Full', n, 1, zero, zero, se, n )
700 CALL clacpy(
' ', k+1, n, a, lda, u, ldu )
704 $ work, lh, work( lh+1 ), lw, iinfo )
708 CALL scopy( n, sd, 1, d2, 1 )
710 $
CALL scopy( n-1, se, 1, rwork, 1 )
712 CALL csteqr(
'N', n, d2, rwork, work, ldu,
713 $ rwork( n+1 ), iinfo )
714 IF( iinfo.NE.0 )
THEN
715 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n,
718 IF( iinfo.LT.0 )
THEN
730 DO 110 jr = 0, min( k, n-jc )
731 a( jr+1, jc ) = conjg( a( k+1-jr, jc+jr ) )
734 DO 140 jc = n + 1 - k, n
735 DO 130 jr = min( k, n-jc ) + 1, k
742 CALL clacpy(
' ', k+1, n, a, lda, work, lda )
745 CALL chbtrd(
'V',
'L', n, k, work, lda, sd, se, u, ldu,
746 $ work( lda*n+1 ), iinfo )
748 IF( iinfo.NE.0 )
THEN
749 WRITE( nounit, fmt = 9999 )
'CHBTRD(L)', iinfo, n,
752 IF( iinfo.LT.0 )
THEN
763 CALL chbt21(
'Lower', n, k, 1, a, lda, sd, se, u, ldu,
764 $ work, rwork, result( 3 ) )
771 CALL slaset(
'Full', n, 1, zero, zero, sd, n )
772 CALL slaset(
'Full', n, 1, zero, zero, se, n )
773 CALL clacpy(
' ', k+1, n, a, lda, u, ldu )
777 $ work, lh, work( lh+1 ), lw, iinfo )
781 CALL scopy( n, sd, 1, d3, 1 )
783 $
CALL scopy( n-1, se, 1, rwork, 1 )
785 CALL csteqr(
'N', n, d3, rwork, work, ldu,
786 $ rwork( n+1 ), iinfo )
787 IF( iinfo.NE.0 )
THEN
788 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n,
791 IF( iinfo.LT.0 )
THEN
810 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
811 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
812 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
813 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
816 result(5) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
817 result(6) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
822 ntestt = ntestt + ntest
827 IF( result( jr ).GE.thresh )
THEN
832 IF( nerrs.EQ.0 )
THEN
833 WRITE( nounit, fmt = 9998 )
'CHB'
834 WRITE( nounit, fmt = 9997 )
835 WRITE( nounit, fmt = 9996 )
836 WRITE( nounit, fmt = 9995 )
'Hermitian'
837 WRITE( nounit, fmt = 9994 )
'unitary',
'*',
838 $
'conjugate transpose', (
'*', j = 1, 6 )
841 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
852 CALL slasum(
'CHB', nounit, nerrs, ntestt )
855 9999
FORMAT(
' CCHKHB2STG: ', a,
' returned INFO=', i6,
'.', / 9x,
856 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
858 9998
FORMAT( / 1x, a3,
859 $
' -- Complex Hermitian Banded Tridiagonal Reduction Routines'
861 9997
FORMAT(
' Matrix types (see SCHK23 for details): ' )
863 9996
FORMAT( /
' Special Matrices:',
864 $ /
' 1=Zero matrix. ',
865 $
' 5=Diagonal: clustered entries.',
866 $ /
' 2=Identity matrix. ',
867 $
' 6=Diagonal: large, evenly spaced.',
868 $ /
' 3=Diagonal: evenly spaced entries. ',
869 $
' 7=Diagonal: small, evenly spaced.',
870 $ /
' 4=Diagonal: geometr. spaced entries.' )
871 9995
FORMAT(
' Dense ', a,
' Banded Matrices:',
872 $ /
' 8=Evenly spaced eigenvals. ',
873 $
' 12=Small, evenly spaced eigenvals.',
874 $ /
' 9=Geometrically spaced eigenvals. ',
875 $
' 13=Matrix with random O(1) entries.',
876 $ /
' 10=Clustered eigenvalues. ',
877 $
' 14=Matrix with large random entries.',
878 $ /
' 11=Large, evenly spaced eigenvals. ',
879 $
' 15=Matrix with small random entries.' )
881 9994
FORMAT( /
' Tests performed: (S is Tridiag, U is ', a,
',',
882 $ / 20x, a,
' means ', a,
'.', /
' UPLO=''U'':',
883 $ /
' 1= | A - U S U', a1,
' | / ( |A| n ulp ) ',
884 $
' 2= | I - U U', a1,
' | / ( n ulp )', /
' UPLO=''L'':',
885 $ /
' 3= | A - U S U', a1,
' | / ( |A| n ulp ) ',
886 $
' 4= | I - U U', a1,
' | / ( n ulp )' /
' Eig check:',
887 $ /
' 5= | D1 - D2',
'',
' | / ( |D1| ulp ) ',
888 $
' 6= | D1 - D3',
'',
' | / ( |D1| ulp ) ' )
889 9993
FORMAT(
' N=', i5,
', K=', i4,
', seed=', 4( i4,
',' ),
' type ',
890 $ i2,
', test(', i2,
')=', g10.3 )