121 SUBROUTINE zhetrs( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
130 INTEGER info, lda, ldb, n, nrhs
134 COMPLEX*16 a( lda, * ),
b( ldb, * )
141 parameter( one = ( 1.0d+0, 0.0d+0 ) )
147 COMPLEX*16 ak, akm1, akm1k, bk, bkm1, denom
157 INTRINSIC dble, dconjg, max
162 upper =
lsame( uplo,
'U' )
163 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
165 ELSE IF( n.LT.0 )
THEN
167 ELSE IF( nrhs.LT.0 )
THEN
169 ELSE IF( lda.LT.max( 1, n ) )
THEN
171 ELSE IF( ldb.LT.max( 1, n ) )
THEN
175 CALL
xerbla(
'ZHETRS', -info )
181 IF( n.EQ.0 .OR. nrhs.EQ.0 )
201 IF( ipiv( k ).GT.0 )
THEN
209 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
214 CALL
zgeru( k-1, nrhs, -one, a( 1, k ), 1,
b( k, 1 ), ldb,
219 s = dble( one ) / dble( a( k, k ) )
220 CALL
zdscal( nrhs, s,
b( k, 1 ), ldb )
230 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
235 CALL
zgeru( k-2, nrhs, -one, a( 1, k ), 1,
b( k, 1 ), ldb,
237 CALL
zgeru( k-2, nrhs, -one, a( 1, k-1 ), 1,
b( k-1, 1 ),
238 $ ldb,
b( 1, 1 ), ldb )
243 akm1 = a( k-1, k-1 ) / akm1k
244 ak = a( k, k ) / dconjg( akm1k )
245 denom = akm1*ak - one
247 bkm1 =
b( k-1,
j ) / akm1k
248 bk =
b( k,
j ) / dconjg( akm1k )
249 b( k-1,
j ) = ( ak*bkm1-bk ) / denom
250 b( k,
j ) = ( akm1*bk-bkm1 ) / denom
271 IF( ipiv( k ).GT.0 )
THEN
279 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
280 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
281 $ ldb, a( 1, k ), 1, one,
b( k, 1 ), ldb )
282 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
289 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
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 )
304 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
305 CALL
zgemv(
'Conjugate transpose', k-1, nrhs, -one,
b,
306 $ ldb, a( 1, k+1 ), 1, one,
b( k+1, 1 ), ldb )
307 CALL
zlacgv( nrhs,
b( k+1, 1 ), ldb )
314 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
338 IF( ipiv( k ).GT.0 )
THEN
346 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
352 $ CALL
zgeru( n-k, nrhs, -one, a( k+1, k ), 1,
b( k, 1 ),
353 $ ldb,
b( k+1, 1 ), ldb )
357 s = dble( one ) / dble( a( k, k ) )
358 CALL
zdscal( nrhs, s,
b( k, 1 ), ldb )
368 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
374 CALL
zgeru( n-k-1, nrhs, -one, a( k+2, k ), 1,
b( k, 1 ),
375 $ ldb,
b( k+2, 1 ), ldb )
376 CALL
zgeru( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
377 $
b( k+1, 1 ), ldb,
b( k+2, 1 ), ldb )
383 akm1 = a( k, k ) / dconjg( akm1k )
384 ak = a( k+1, k+1 ) / akm1k
385 denom = akm1*ak - one
387 bkm1 =
b( k,
j ) / dconjg( akm1k )
388 bk =
b( k+1,
j ) / akm1k
389 b( k,
j ) = ( ak*bkm1-bk ) / denom
390 b( k+1,
j ) = ( akm1*bk-bkm1 ) / denom
411 IF( ipiv( k ).GT.0 )
THEN
419 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
420 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
421 $
b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
423 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
430 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
440 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
441 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
442 $
b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
444 CALL
zlacgv( nrhs,
b( k, 1 ), ldb )
446 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
447 CALL
zgemv(
'Conjugate transpose', n-k, nrhs, -one,
448 $
b( k+1, 1 ), ldb, a( k+1, k-1 ), 1, one,
450 CALL
zlacgv( nrhs,
b( k-1, 1 ), ldb )
457 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
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.
logical function lsame(CA, CB)
LSAME
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zhetrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZHETRS
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU