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 zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zhetrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZHETRS
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.