211 SUBROUTINE zhet21( 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 DOUBLE PRECISION d( * ), e( * ), result( 2 ), rwork( * )
225 COMPLEX*16 a( lda, * ), tau( * ), u( ldu, * ),
226 $ v( ldv, * ), work( * )
232 DOUBLE PRECISION zero, one, ten
233 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
234 COMPLEX*16 czero, cone
235 parameter( czero = ( 0.0d+0, 0.0d+0 ),
236 $ cone = ( 1.0d+0, 0.0d+0 ) )
241 INTEGER iinfo,
j, jcol, jr, jrow
242 DOUBLE PRECISION anorm, ulp, unfl, wnorm
255 INTRINSIC dble, dcmplx, max, min
265 IF(
lsame( uplo,
'U' ) )
THEN
273 unfl =
dlamch(
'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(
zlanhe(
'1', cuplo, n, a, lda, rwork ), unfl )
295 IF( itype.EQ.1 )
THEN
299 CALL
zlaset(
'Full', n, n, czero, czero, work, n )
300 CALL
zlacpy( cuplo, n, n, a, lda, work, n )
303 CALL
zher( cuplo, n, -d(
j ), u( 1,
j ), 1, work, n )
306 IF( n.GT.1 .AND. kband.EQ.1 )
THEN
308 CALL
zher2( cuplo, n, -dcmplx( e(
j ) ), u( 1,
j ), 1,
309 $ u( 1,
j-1 ), 1, work, n )
312 wnorm =
zlanhe(
'1', cuplo, n, work, n, rwork )
314 ELSE IF( itype.EQ.2 )
THEN
318 CALL
zlaset(
'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
zlarfy(
'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
zlarfy(
'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 =
zlanhe(
'1', cuplo, n, work, n, rwork )
371 ELSE IF( itype.EQ.3 )
THEN
377 CALL
zlacpy(
' ', n, n, u, ldu, work, n )
379 CALL
zunm2r(
'R',
'C', n, n-1, n-1, v( 2, 1 ), ldv, tau,
380 $ work( n+1 ), n, work( n**2+1 ), iinfo )
382 CALL
zunm2l(
'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 =
zlange(
'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, dble( n ) ) / ( n*ulp )
411 IF( itype.EQ.1 )
THEN
412 CALL
zgemm(
'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(
zlange(
'1', n, n, work, n, rwork ),
420 $ dble( n ) ) / ( n*ulp )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zlanhe(NORM, UPLO, N, A, LDA, WORK)
ZLANHE 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 zunm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
logical function lsame(CA, CB)
LSAME
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zher(UPLO, N, ALPHA, X, INCX, A, LDA)
ZHER
subroutine zunm2l(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
subroutine zhet21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RWORK, RESULT)
ZHET21
subroutine zher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZHER2
subroutine zlarfy(UPLO, N, V, INCV, TAU, C, LDC, WORK)
ZLARFY