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 )