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
255 INTRINSIC cmplx, max, min, real
265 IF(
lsame( uplo,
'U' ) )
THEN
273 unfl =
slamch(
'Safe minimum' )
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...
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
real function clanhe(NORM, UPLO, N, A, LDA, WORK)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
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
logical function lsame(CA, CB)
LSAME
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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...