116 SUBROUTINE chptrs( 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 ) )
142 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
152 INTRINSIC conjg, max, real
157 upper = lsame( uplo,
'U' )
158 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
160 ELSE IF( n.LT.0 )
THEN
162 ELSE IF( nrhs.LT.0 )
THEN
164 ELSE IF( ldb.LT.max( 1, n ) )
THEN
168 CALL
xerbla(
'CHPTRS', -info )
174 IF( n.EQ.0 .OR. nrhs.EQ.0 )
187 kc = n*( n+1 ) / 2 + 1
196 IF( ipiv( k ).GT.0 )
THEN
204 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
209 CALL
cgeru( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
214 s =
REAL( ONE ) /
REAL( AP( KC+K-1 ) )
215 CALL
csscal( nrhs, s, b( k, 1 ), ldb )
225 $ CALL
cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
230 CALL
cgeru( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
232 CALL
cgeru( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,
233 $ b( k-1, 1 ), ldb, b( 1, 1 ), ldb )
238 akm1 = ap( kc-1 ) / akm1k
239 ak = ap( kc+k-1 ) / conjg( akm1k )
240 denom = akm1*ak - one
242 bkm1 = b( k-1, j ) / akm1k
243 bk = b( k, j ) / conjg( akm1k )
244 b( k-1, j ) = ( ak*bkm1-bk ) / denom
245 b( k, j ) = ( akm1*bk-bkm1 ) / denom
268 IF( ipiv( k ).GT.0 )
THEN
276 CALL
clacgv( nrhs, b( k, 1 ), ldb )
277 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
278 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
279 CALL
clacgv( nrhs, b( k, 1 ), ldb )
286 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
297 CALL
clacgv( nrhs, b( k, 1 ), ldb )
298 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
299 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
300 CALL
clacgv( nrhs, b( k, 1 ), ldb )
302 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
303 CALL
cgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
304 $ ldb, ap( kc+k ), 1, one, b( k+1, 1 ), ldb )
305 CALL
clacgv( nrhs, b( k+1, 1 ), ldb )
312 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
338 IF( ipiv( k ).GT.0 )
THEN
346 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
352 $ CALL
cgeru( n-k, nrhs, -one, ap( kc+1 ), 1, b( k, 1 ),
353 $ ldb, b( k+1, 1 ), ldb )
357 s =
REAL( ONE ) /
REAL( AP( KC ) )
358 CALL
csscal( nrhs, s, b( k, 1 ), ldb )
369 $ CALL
cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
375 CALL
cgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
376 $ ldb, b( k+2, 1 ), ldb )
377 CALL
cgeru( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1,
378 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
384 akm1 = ap( kc ) / conjg( akm1k )
385 ak = ap( kc+n-k+1 ) / akm1k
386 denom = akm1*ak - one
388 bkm1 = b( k, j ) / conjg( akm1k )
389 bk = b( k+1, j ) / akm1k
390 b( k, j ) = ( ak*bkm1-bk ) / denom
391 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
393 kc = kc + 2*( n-k ) + 1
406 kc = n*( n+1 ) / 2 + 1
415 IF( ipiv( k ).GT.0 )
THEN
423 CALL
clacgv( nrhs, b( k, 1 ), ldb )
424 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
425 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
427 CALL
clacgv( nrhs, b( k, 1 ), ldb )
434 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
444 CALL
clacgv( nrhs, b( k, 1 ), ldb )
445 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
446 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
448 CALL
clacgv( nrhs, b( k, 1 ), ldb )
450 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
451 CALL
cgemv(
'Conjugate transpose', n-k, nrhs, -one,
452 $ b( k+1, 1 ), ldb, ap( kc-( n-k ) ), 1, one,
454 CALL
clacgv( nrhs, b( k-1, 1 ), ldb )
461 $ CALL
cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine chptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CHPTRS
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU