211 SUBROUTINE chet21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V,
212 $ ldv, tau, work, rwork, result )
221 INTEGER ITYPE, KBAND, LDA, LDU, LDV, N
224 REAL D( * ), E( * ), RESULT( 2 ), RWORK( * )
225 COMPLEX A( lda, * ), TAU( * ), U( ldu, * ),
226 $ v( ldv, * ), work( * )
233 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
235 parameter( czero = ( 0.0e+0, 0.0e+0 ),
236 $ cone = ( 1.0e+0, 0.0e+0 ) )
241 INTEGER IINFO, J, JCOL, JR, JROW
242 REAL ANORM, ULP, UNFL, WNORM
247 REAL CLANGE, CLANHE, SLAMCH
248 EXTERNAL lsame, clange, clanhe, slamch
255 INTRINSIC cmplx, max, min, real
265 IF( lsame( uplo,
'U' ) )
THEN
273 unfl = slamch(
'Safe minimum' )
274 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
278 IF( itype.LT.1 .OR. itype.GT.3 )
THEN
279 result( 1 ) = ten / ulp
287 IF( itype.EQ.3 )
THEN
290 anorm = max( clanhe(
'1', cuplo, n, a, lda, rwork ), unfl )
295 IF( itype.EQ.1 )
THEN
299 CALL
claset(
'Full', n, n, czero, czero, work, n )
300 CALL
clacpy( cuplo, n, n, a, lda, work, n )
303 CALL
cher( cuplo, n, -d( j ), u( 1, j ), 1, work, n )
306 IF( n.GT.1 .AND. kband.EQ.1 )
THEN
308 CALL
cher2( cuplo, n, -cmplx( e( j ) ), u( 1, j ), 1,
309 $ u( 1, j-1 ), 1, work, n )
312 wnorm = clanhe(
'1', cuplo, n, work, n, rwork )
314 ELSE IF( itype.EQ.2 )
THEN
318 CALL
claset(
'Full', n, n, czero, czero, work, n )
321 work( n**2 ) = d( n )
322 DO 40 j = n - 1, 1, -1
323 IF( kband.EQ.1 )
THEN
324 work( ( n+1 )*( j-1 )+2 ) = ( cone-tau( j ) )*e( j )
326 work( ( j-1 )*n+jr ) = -tau( j )*e( j )*v( jr, j )
332 CALL
clarfy(
'L', n-j, v( j+1, j ), 1, tau( j ),
333 $ work( ( n+1 )*j+1 ), n, work( n**2+1 ) )
335 work( ( n+1 )*( j-1 )+1 ) = d( j )
340 IF( kband.EQ.1 )
THEN
341 work( ( n+1 )*j ) = ( cone-tau( j ) )*e( j )
343 work( j*n+jr ) = -tau( j )*e( j )*v( jr, j+1 )
349 CALL
clarfy(
'U', j, v( 1, j+1 ), 1, tau( j ), work, n,
352 work( ( n+1 )*j+1 ) = d( j+1 )
359 work( jrow+n*( jcol-1 ) ) = work( jrow+n*( jcol-1 ) )
364 work( jrow+n*( jcol-1 ) ) = work( jrow+n*( jcol-1 ) )
369 wnorm = clanhe(
'1', cuplo, n, work, n, rwork )
371 ELSE IF( itype.EQ.3 )
THEN
377 CALL
clacpy(
' ', n, n, u, ldu, work, n )
379 CALL
cunm2r(
'R',
'C', n, n-1, n-1, v( 2, 1 ), ldv, tau,
380 $ work( n+1 ), n, work( n**2+1 ), iinfo )
382 CALL
cunm2l(
'R',
'C', n, n-1, n-1, v( 1, 2 ), ldv, tau,
383 $ work, n, work( n**2+1 ), iinfo )
385 IF( iinfo.NE.0 )
THEN
386 result( 1 ) = ten / ulp
391 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
394 wnorm = clange(
'1', n, n, work, n, rwork )
397 IF( anorm.GT.wnorm )
THEN
398 result( 1 ) = ( wnorm / anorm ) / ( n*ulp )
400 IF( anorm.LT.one )
THEN
401 result( 1 ) = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
403 result( 1 ) = min( wnorm / anorm,
REAL( N ) ) / ( N*ULP )
411 IF( itype.EQ.1 )
THEN
412 CALL
cgemm(
'N',
'C', n, n, n, cone, u, ldu, u, ldu, czero,
416 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
419 result( 2 ) = min( clange(
'1', n, n, work, n, rwork ),
420 $
REAL( N ) ) / ( N*ULP )
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 clarfy(UPLO, N, V, INCV, TAU, C, LDC, WORK)
CLARFY
subroutine cunm2l(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
CUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
CHER
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CHER2
subroutine chet21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RWORK, RESULT)
CHET21
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine cunm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...