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...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
logical function lsame(CA, CB)
LSAME
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU