146 INTEGER info, lda, ldb, n, nrhs
150 COMPLEX*16 a( lda, * ),
b( ldb, * )
157 parameter( one = ( 1.0d+0, 0.0d+0 ) )
163 COMPLEX*16 ak, akm1, akm1k, bk, bkm1, denom
173 INTRINSIC dconjg, max, dble
178 upper =
lsame( uplo,
'U' )
179 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
181 ELSE IF( n.LT.0 )
THEN
183 ELSE IF( nrhs.LT.0 )
THEN
185 ELSE IF( lda.LT.max( 1, n ) )
THEN
187 ELSE IF( ldb.LT.max( 1, n ) )
THEN
191 CALL
xerbla(
'ZHETRS_ROOK', -info )
197 IF( n.EQ.0 .OR. nrhs.EQ.0 )
217 IF( ipiv( k ).GT.0 )
THEN
225 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
230 CALL
zgeru( k-1, nrhs, -one, a( 1, k ), 1,
b( k, 1 ), ldb,
235 s = dble( one ) / dble( a( k, k ) )
236 CALL
zdscal( nrhs, s,
b( k, 1 ), ldb )
246 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
250 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
255 CALL
zgeru( k-2, nrhs, -one, a( 1, k ), 1,
b( k, 1 ), ldb,
257 CALL
zgeru( k-2, nrhs, -one, a( 1, k-1 ), 1,
b( k-1, 1 ),
258 $ ldb,
b( 1, 1 ), ldb )
263 akm1 = a( k-1, k-1 ) / akm1k
264 ak = a( k, k ) / dconjg( akm1k )
265 denom = akm1*ak - one
267 bkm1 =
b( k-1,
j ) / akm1k
268 bk =
b( k,
j ) / dconjg( akm1k )
269 b( k-1,
j ) = ( ak*bkm1-bk ) / denom
270 b( k,
j ) = ( akm1*bk-bkm1 ) / denom
291 IF( ipiv( k ).GT.0 )
THEN
299 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
300 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
301 $ ldb, a( 1, k ), 1, one,
b( k, 1 ), ldb )
302 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
309 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
319 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
320 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
321 $ ldb, a( 1, k ), 1, one,
b( k, 1 ), ldb )
322 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
324 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
325 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
326 $ ldb, a( 1, k+1 ), 1, one,
b( k+1, 1 ), ldb )
327 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
334 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
338 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
363 IF( ipiv( k ).GT.0 )
THEN
371 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
377 $ CALL
zgeru( n-k, nrhs, -one, a( k+1, k ), 1,
b( k, 1 ),
378 $ ldb,
b( k+1, 1 ), ldb )
382 s = dble( one ) / dble( a( k, k ) )
383 CALL
zdscal( nrhs, s,
b( k, 1 ), ldb )
393 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
397 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
403 CALL
zgeru( n-k-1, nrhs, -one, a( k+2, k ), 1,
b( k, 1 ),
404 $ ldb,
b( k+2, 1 ), ldb )
405 CALL
zgeru( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
406 $
b( k+1, 1 ), ldb,
b( k+2, 1 ), ldb )
412 akm1 = a( k, k ) / dconjg( akm1k )
413 ak = a( k+1, k+1 ) / akm1k
414 denom = akm1*ak - one
416 bkm1 =
b( k,
j ) / dconjg( akm1k )
417 bk =
b( k+1,
j ) / akm1k
418 b( k,
j ) = ( ak*bkm1-bk ) / denom
419 b( k+1,
j ) = ( akm1*bk-bkm1 ) / denom
440 IF( ipiv( k ).GT.0 )
THEN
448 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
449 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
450 $
b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
452 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
459 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
469 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
470 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
471 $
b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
473 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
475 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
476 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
477 $
b( k+1, 1 ), ldb, a( k+1, k-1 ), 1, one,
479 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
486 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
490 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
subroutine zhetrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
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 zdscal(N, DA, ZX, INCX)
ZDSCAL
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 zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU