136 SUBROUTINE csytrs_rook( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
146 INTEGER INFO, LDA, LDB, N, NRHS
150 COMPLEX A( lda, * ), B( ldb, * )
157 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
162 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
177 upper = lsame( uplo,
'U' )
178 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
180 ELSE IF( n.LT.0 )
THEN
182 ELSE IF( nrhs.LT.0 )
THEN
184 ELSE IF( lda.LT.max( 1, n ) )
THEN
186 ELSE IF( ldb.LT.max( 1, n ) )
THEN
190 CALL xerbla(
'CSYTRS_ROOK', -info )
196 IF( n.EQ.0 .OR. nrhs.EQ.0 )
216 IF( ipiv( k ).GT.0 )
THEN
224 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
229 CALL cgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,
234 CALL cscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb )
244 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
248 $
CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
254 CALL cgeru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),
255 $ ldb, b( 1, 1 ), ldb )
256 CALL cgeru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),
257 $ ldb, b( 1, 1 ), ldb )
263 akm1 = a( k-1, k-1 ) / akm1k
264 ak = a( k, k ) / akm1k
265 denom = akm1*ak - cone
267 bkm1 = b( k-1, j ) / akm1k
268 bk = b( k, j ) / 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 cgemv(
'Transpose', k-1, nrhs, -cone, b,
300 $ ldb, a( 1, k ), 1, cone, b( k, 1 ), ldb )
306 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
316 CALL cgemv(
'Transpose', k-1, nrhs, -cone, b,
317 $ ldb, a( 1, k ), 1, cone, b( k, 1 ), ldb )
318 CALL cgemv(
'Transpose', k-1, nrhs, -cone, b,
319 $ ldb, a( 1, k+1 ), 1, cone, b( k+1, 1 ), ldb )
326 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
330 $
CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
355 IF( ipiv( k ).GT.0 )
THEN
363 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
369 $
CALL cgeru( n-k, nrhs, -cone, a( k+1, k ), 1, b( k, 1 ),
370 $ ldb, b( k+1, 1 ), ldb )
374 CALL cscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb )
384 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
388 $
CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
394 CALL cgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1, b( k, 1 ),
395 $ ldb, b( k+2, 1 ), ldb )
396 CALL cgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1,
397 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
403 akm1 = a( k, k ) / akm1k
404 ak = a( k+1, k+1 ) / akm1k
405 denom = akm1*ak - cone
407 bkm1 = b( k, j ) / akm1k
408 bk = b( k+1, j ) / akm1k
409 b( k, j ) = ( ak*bkm1-bk ) / denom
410 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
431 IF( ipiv( k ).GT.0 )
THEN
439 $
CALL cgemv(
'Transpose', n-k, nrhs, -cone, b( k+1, 1 ),
440 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
446 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
456 CALL cgemv(
'Transpose', n-k, nrhs, -cone, b( k+1, 1 ),
457 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
458 CALL cgemv(
'Transpose', n-k, nrhs, -cone, b( k+1, 1 ),
459 $ ldb, a( k+1, k-1 ), 1, cone, b( k-1, 1 ),
467 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
471 $
CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine csytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CSYTRS_ROOK
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU