136 SUBROUTINE chetrs_rook( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
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