121 SUBROUTINE chetrs( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
130 INTEGER INFO, LDA, LDB, N, NRHS
134 COMPLEX A( lda, * ), B( ldb, * )
141 parameter( one = ( 1.0e+0, 0.0e+0 ) )
147 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
157 INTRINSIC conjg, max, real
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(
'CHETRS', -info )
181 IF( n.EQ.0 .OR. nrhs.EQ.0 )
201 IF( ipiv( k ).GT.0 )
THEN
209 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
214 CALL
cgeru( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
219 s =
REAL( ONE ) /
REAL( A( K, K ) )
220 CALL
csscal( nrhs, s, b( k, 1 ), ldb )
230 $ CALL
cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
235 CALL
cgeru( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
237 CALL
cgeru( 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 ) / conjg( akm1k )
245 denom = akm1*ak - one
247 bkm1 = b( k-1, j ) / akm1k
248 bk = b( k, j ) / conjg( 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
clacgv( nrhs, b( k, 1 ), ldb )
280 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
281 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
282 CALL
clacgv( nrhs, b( k, 1 ), ldb )
289 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
299 CALL
clacgv( nrhs, b( k, 1 ), ldb )
300 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
301 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
302 CALL
clacgv( nrhs, b( k, 1 ), ldb )
304 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
305 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
306 $ ldb, a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb )
307 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
314 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
338 IF( ipiv( k ).GT.0 )
THEN
346 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
352 $ CALL
cgeru( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ),
353 $ ldb, b( k+1, 1 ), ldb )
357 s =
REAL( ONE ) /
REAL( A( K, K ) )
358 CALL
csscal( nrhs, s, b( k, 1 ), ldb )
368 $ CALL
cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
374 CALL
cgeru( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
375 $ ldb, b( k+2, 1 ), ldb )
376 CALL
cgeru( 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 ) / conjg( akm1k )
384 ak = a( k+1, k+1 ) / akm1k
385 denom = akm1*ak - one
387 bkm1 = b( k, j ) / conjg( 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
clacgv( nrhs, b( k, 1 ), ldb )
420 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
421 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
423 CALL
clacgv( nrhs, b( k, 1 ), ldb )
430 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
440 CALL
clacgv( nrhs, b( k, 1 ), ldb )
441 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
442 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
444 CALL
clacgv( nrhs, b( k, 1 ), ldb )
446 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
447 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
448 $ b( k+1, 1 ), ldb, a( k+1, k-1 ), 1, one,
450 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
457 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
subroutine chetrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CHETRS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU