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
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
LOGICAL function lsame(CA, CB)
LSAME
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zlavhe_rook(UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZLAVHE_ROOK
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU