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 cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU
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 csscal(N, SA, CX, INCX)
CSSCAL