146 INTEGER info, lda, ldb, n, nrhs
150 COMPLEX*16 a( lda, * ),
b( ldb, * )
157 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
162 COMPLEX*16 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(
'ZSYTRS_ROOK', -info )
196 IF( n.EQ.0 .OR. nrhs.EQ.0 )
216 IF( ipiv( k ).GT.0 )
THEN
224 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
229 CALL
zgeru( k-1, nrhs, -cone, a( 1, k ), 1,
b( k, 1 ), ldb,
234 CALL
zscal( nrhs, cone / a( k, k ),
b( k, 1 ), ldb )
244 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
248 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
254 CALL
zgeru( k-2, nrhs,-cone, a( 1, k ), 1,
b( k, 1 ),
255 $ ldb,
b( 1, 1 ), ldb )
256 CALL
zgeru( 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
zgemv(
'Transpose', k-1, nrhs, -cone,
b,
300 $ ldb, a( 1, k ), 1, cone,
b( k, 1 ), ldb )
306 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
316 CALL
zgemv(
'Transpose', k-1, nrhs, -cone,
b,
317 $ ldb, a( 1, k ), 1, cone,
b( k, 1 ), ldb )
318 CALL
zgemv(
'Transpose', k-1, nrhs, -cone,
b,
319 $ ldb, a( 1, k+1 ), 1, cone,
b( k+1, 1 ), ldb )
326 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
330 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
355 IF( ipiv( k ).GT.0 )
THEN
363 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
369 $ CALL
zgeru( n-k, nrhs, -cone, a( k+1, k ), 1,
b( k, 1 ),
370 $ ldb,
b( k+1, 1 ), ldb )
374 CALL
zscal( nrhs, cone / a( k, k ),
b( k, 1 ), ldb )
384 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
388 $ CALL
zswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
394 CALL
zgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1,
b( k, 1 ),
395 $ ldb,
b( k+2, 1 ), ldb )
396 CALL
zgeru( 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
zgemv(
'Transpose', n-k, nrhs, -cone,
b( k+1, 1 ),
440 $ ldb, a( k+1, k ), 1, cone,
b( k, 1 ), ldb )
446 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
456 CALL
zgemv(
'Transpose', n-k, nrhs, -cone,
b( k+1, 1 ),
457 $ ldb, a( k+1, k ), 1, cone,
b( k, 1 ), ldb )
458 CALL
zgemv(
'Transpose', n-k, nrhs, -cone,
b( k+1, 1 ),
459 $ ldb, a( k+1, k-1 ), 1, cone,
b( k-1, 1 ),
467 $ CALL
zswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
471 $ CALL
zswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
LOGICAL function lsame(CA, CB)
LSAME
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zsytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZSYTRS_ROOK
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU