162 CHARACTER diag, trans, uplo
163 INTEGER info, lda, ldb, n, nrhs
167 COMPLEX*16 a( lda, * ),
b( ldb, * )
174 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
179 COMPLEX*16 d11, d12, d21, d22, t1, t2
189 INTRINSIC abs, dconjg, max
196 IF( .NOT.
lsame( uplo,
'U' ) .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
198 ELSE IF( .NOT.
lsame( trans,
'N' ) .AND. .NOT.
lsame( trans,
'C' ) )
201 ELSE IF( .NOT.
lsame( diag,
'U' ) .AND. .NOT.
lsame( diag,
'N' ) )
204 ELSE IF( n.LT.0 )
THEN
206 ELSE IF( lda.LT.max( 1, n ) )
THEN
208 ELSE IF( ldb.LT.max( 1, n ) )
THEN
212 CALL
xerbla(
'ZLAVHE_ROOK ', -info )
221 nounit =
lsame( diag,
'N' )
227 IF(
lsame( trans,
'N' ) )
THEN
232 IF(
lsame( uplo,
'U' ) )
THEN
240 IF( ipiv( k ).GT.0 )
THEN
247 $ CALL
zscal( nrhs, a( k, k ),
b( k, 1 ), ldb )
255 CALL
zgeru( k-1, nrhs, cone, a( 1, k ), 1,
b( k, 1 ),
256 $ ldb,
b( 1, 1 ), ldb )
262 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
279 b( k,
j ) = d11*t1 + d12*t2
280 b( k+1,
j ) = d21*t1 + d22*t2
290 CALL
zgeru( k-1, nrhs, cone, a( 1, k ), 1,
b( k, 1 ),
291 $ ldb,
b( 1, 1 ), ldb )
292 CALL
zgeru( k-1, nrhs, cone, a( 1, k+1 ), 1,
293 $
b( k+1, 1 ), ldb,
b( 1, 1 ), ldb )
300 kp = abs( ipiv( k ) )
302 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
306 kp = abs( ipiv( k+1 ) )
308 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ),
331 IF( ipiv( k ).GT.0 )
THEN
338 $ CALL
zscal( nrhs, a( k, k ),
b( k, 1 ), ldb )
347 CALL
zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
348 $
b( k, 1 ), ldb,
b( k+1, 1 ), ldb )
354 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
372 b( k-1,
j ) = d11*t1 + d12*t2
373 b( k,
j ) = d21*t1 + d22*t2
383 CALL
zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
384 $
b( k, 1 ), ldb,
b( k+1, 1 ), ldb )
385 CALL
zgeru( n-k, nrhs, cone, a( k+1, k-1 ), 1,
386 $
b( k-1, 1 ), ldb,
b( k+1, 1 ), ldb )
394 kp = abs( ipiv( k ) )
396 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
400 kp = abs( ipiv( k-1 ) )
402 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ),
422 IF(
lsame( uplo,
'U' ) )
THEN
432 IF( ipiv( k ).GT.0 )
THEN
439 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
445 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
446 CALL
zgemv(
'Conjugate', k-1, nrhs, cone,
b, ldb,
447 $ a( 1, k ), 1, cone,
b( k, 1 ), ldb )
448 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
451 $ CALL
zscal( nrhs, a( k, k ),
b( k, 1 ), ldb )
461 kp = abs( ipiv( k ) )
463 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
467 kp = abs( ipiv( k-1 ) )
469 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ),
477 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
478 CALL
zgemv(
'Conjugate', k-2, nrhs, cone,
b, ldb,
479 $ a( 1, k ), 1, cone,
b( k, 1 ), ldb )
480 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
482 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
483 CALL
zgemv(
'Conjugate', k-2, nrhs, cone,
b, ldb,
484 $ a( 1, k-1 ), 1, cone,
b( k-1, 1 ), ldb )
485 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
498 b( k-1,
j ) = d11*t1 + d12*t2
499 b( k,
j ) = d21*t1 + d22*t2
522 IF( ipiv( k ).GT.0 )
THEN
529 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
533 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
534 CALL
zgemv(
'Conjugate', n-k, nrhs, cone,
b( k+1, 1 ),
535 $ ldb, a( k+1, k ), 1, cone,
b( k, 1 ), ldb )
536 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
539 $ CALL
zscal( nrhs, a( k, k ),
b( k, 1 ), ldb )
549 kp = abs( ipiv( k ) )
551 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
555 kp = abs( ipiv( k+1 ) )
557 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ),
562 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
563 CALL
zgemv(
'Conjugate', n-k-1, nrhs, cone,
564 $
b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
566 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
568 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
569 CALL
zgemv(
'Conjugate', n-k-1, nrhs, cone,
570 $
b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
572 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
585 b( k,
j ) = d11*t1 + d12*t2
586 b( k+1,
j ) = d21*t1 + d22*t2