146 INTEGER INFO, LDA, LDB, N, NRHS
150 COMPLEX A( lda, * ), B( ldb, * )
157 parameter( one = ( 1.0e+0, 0.0e+0 ) )
163 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
173 INTRINSIC conjg, max, real
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(
'CHETRS_ROOK', -info )
197 IF( n.EQ.0 .OR. nrhs.EQ.0 )
217 IF( ipiv( k ).GT.0 )
THEN
225 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
230 CALL
cgeru( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
235 s =
REAL( ONE ) /
REAL( A( K, K ) )
236 CALL
csscal( nrhs, s, b( k, 1 ), ldb )
246 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
250 $ CALL
cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
255 CALL
cgeru( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
257 CALL
cgeru( 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 ) / conjg( akm1k )
265 denom = akm1*ak - one
267 bkm1 = b( k-1, j ) / akm1k
268 bk = b( k, j ) / conjg( 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
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 )
309 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
319 CALL
clacgv( nrhs, b( k, 1 ), ldb )
320 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
321 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
322 CALL
clacgv( nrhs, b( k, 1 ), ldb )
324 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
325 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
326 $ ldb, a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb )
327 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
334 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
338 $ CALL
cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
363 IF( ipiv( k ).GT.0 )
THEN
371 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
377 $ CALL
cgeru( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ),
378 $ ldb, b( k+1, 1 ), ldb )
382 s =
REAL( ONE ) /
REAL( A( K, K ) )
383 CALL
csscal( nrhs, s, b( k, 1 ), ldb )
393 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
397 $ CALL
cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
403 CALL
cgeru( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
404 $ ldb, b( k+2, 1 ), ldb )
405 CALL
cgeru( 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 ) / conjg( akm1k )
413 ak = a( k+1, k+1 ) / akm1k
414 denom = akm1*ak - one
416 bkm1 = b( k, j ) / conjg( 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
clacgv( nrhs, b( k, 1 ), ldb )
449 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
450 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
452 CALL
clacgv( nrhs, b( k, 1 ), ldb )
459 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
469 CALL
clacgv( nrhs, b( k, 1 ), ldb )
470 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
471 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
473 CALL
clacgv( nrhs, b( k, 1 ), ldb )
475 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
476 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
477 $ b( k+1, 1 ), ldb, a( k+1, k-1 ), 1, one,
479 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
486 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
490 $ CALL
cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chetrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
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