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 cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine csytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CSYTRS_ROOK
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU