116 SUBROUTINE csptrs( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
125 INTEGER info, ldb, n, nrhs
129 COMPLEX ap( * ),
b( ldb, * )
136 parameter( one = ( 1.0e+0, 0.0e+0 ) )
141 COMPLEX ak, akm1, akm1k, bk, bkm1, denom
156 upper =
lsame( uplo,
'U' )
157 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
159 ELSE IF( n.LT.0 )
THEN
161 ELSE IF( nrhs.LT.0 )
THEN
163 ELSE IF( ldb.LT.max( 1, n ) )
THEN
167 CALL
xerbla(
'CSPTRS', -info )
173 IF( n.EQ.0 .OR. nrhs.EQ.0 )
186 kc = n*( n+1 ) / 2 + 1
195 IF( ipiv( k ).GT.0 )
THEN
203 $ CALL
cswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
208 CALL
cgeru( k-1, nrhs, -one, ap( kc ), 1,
b( k, 1 ), ldb,
213 CALL
cscal( nrhs, one / ap( kc+k-1 ),
b( k, 1 ), ldb )
223 $ CALL
cswap( nrhs,
b( k-1, 1 ), ldb,
b( kp, 1 ), ldb )
228 CALL
cgeru( k-2, nrhs, -one, ap( kc ), 1,
b( k, 1 ), ldb,
230 CALL
cgeru( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,
231 $
b( k-1, 1 ), ldb,
b( 1, 1 ), ldb )
236 akm1 = ap( kc-1 ) / akm1k
237 ak = ap( kc+k-1 ) / akm1k
238 denom = akm1*ak - one
240 bkm1 =
b( k-1,
j ) / akm1k
241 bk =
b( k,
j ) / akm1k
242 b( k-1,
j ) = ( ak*bkm1-bk ) / denom
243 b( k,
j ) = ( akm1*bk-bkm1 ) / denom
266 IF( ipiv( k ).GT.0 )
THEN
273 CALL
cgemv(
'Transpose', k-1, nrhs, -one,
b, ldb, ap( kc ),
274 $ 1, one,
b( k, 1 ), ldb )
280 $ CALL
cswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
290 CALL
cgemv(
'Transpose', k-1, nrhs, -one,
b, ldb, ap( kc ),
291 $ 1, one,
b( k, 1 ), ldb )
292 CALL
cgemv(
'Transpose', k-1, nrhs, -one,
b, ldb,
293 $ ap( kc+k ), 1, one,
b( k+1, 1 ), ldb )
299 $ CALL
cswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
325 IF( ipiv( k ).GT.0 )
THEN
333 $ CALL
cswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
339 $ CALL
cgeru( n-k, nrhs, -one, ap( kc+1 ), 1,
b( k, 1 ),
340 $ ldb,
b( k+1, 1 ), ldb )
344 CALL
cscal( nrhs, one / ap( kc ),
b( k, 1 ), ldb )
355 $ CALL
cswap( nrhs,
b( k+1, 1 ), ldb,
b( kp, 1 ), ldb )
361 CALL
cgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1,
b( k, 1 ),
362 $ ldb,
b( k+2, 1 ), ldb )
363 CALL
cgeru( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1,
364 $
b( k+1, 1 ), ldb,
b( k+2, 1 ), ldb )
370 akm1 = ap( kc ) / akm1k
371 ak = ap( kc+n-k+1 ) / akm1k
372 denom = akm1*ak - one
374 bkm1 =
b( k,
j ) / akm1k
375 bk =
b( k+1,
j ) / akm1k
376 b( k,
j ) = ( ak*bkm1-bk ) / denom
377 b( k+1,
j ) = ( akm1*bk-bkm1 ) / denom
379 kc = kc + 2*( n-k ) + 1
392 kc = n*( n+1 ) / 2 + 1
401 IF( ipiv( k ).GT.0 )
THEN
409 $ CALL
cgemv(
'Transpose', n-k, nrhs, -one,
b( k+1, 1 ),
410 $ ldb, ap( kc+1 ), 1, one,
b( k, 1 ), ldb )
416 $ CALL
cswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
426 CALL
cgemv(
'Transpose', n-k, nrhs, -one,
b( k+1, 1 ),
427 $ ldb, ap( kc+1 ), 1, one,
b( k, 1 ), ldb )
428 CALL
cgemv(
'Transpose', n-k, nrhs, -one,
b( k+1, 1 ),
429 $ ldb, ap( kc-( n-k ) ), 1, one,
b( k-1, 1 ),
437 $ CALL
cswap( nrhs,
b( k, 1 ), ldb,
b( kp, 1 ), ldb )
LOGICAL function lsame(CA, CB)
LSAME
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
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
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine csptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CSPTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU