116 SUBROUTINE zhptrs( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
125 INTEGER INFO, LDB, N, NRHS
129 COMPLEX*16 AP( * ), B( ldb, * )
136 parameter ( one = ( 1.0d+0, 0.0d+0 ) )
142 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
152 INTRINSIC dble, dconjg, max
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(
'ZHPTRS', -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 zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
209 CALL zgeru( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
214 s = dble( one ) / dble( ap( kc+k-1 ) )
215 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
225 $
CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
230 CALL zgeru( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
232 CALL zgeru( 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 ) / dconjg( akm1k )
240 denom = akm1*ak - one
242 bkm1 = b( k-1, j ) / akm1k
243 bk = b( k, j ) / dconjg( 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 zlacgv( nrhs, b( k, 1 ), ldb )
277 CALL zgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
278 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
279 CALL zlacgv( nrhs, b( k, 1 ), ldb )
286 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
297 CALL zlacgv( nrhs, b( k, 1 ), ldb )
298 CALL zgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
299 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
300 CALL zlacgv( nrhs, b( k, 1 ), ldb )
302 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
303 CALL zgemv(
'Conjugate transpose', k-1, nrhs, -one, b,
304 $ ldb, ap( kc+k ), 1, one, b( k+1, 1 ), ldb )
305 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
312 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
338 IF( ipiv( k ).GT.0 )
THEN
346 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
352 $
CALL zgeru( n-k, nrhs, -one, ap( kc+1 ), 1, b( k, 1 ),
353 $ ldb, b( k+1, 1 ), ldb )
357 s = dble( one ) / dble( ap( kc ) )
358 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
369 $
CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
375 CALL zgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
376 $ ldb, b( k+2, 1 ), ldb )
377 CALL zgeru( 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 ) / dconjg( akm1k )
385 ak = ap( kc+n-k+1 ) / akm1k
386 denom = akm1*ak - one
388 bkm1 = b( k, j ) / dconjg( 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 zlacgv( nrhs, b( k, 1 ), ldb )
424 CALL zgemv(
'Conjugate transpose', n-k, nrhs, -one,
425 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
427 CALL zlacgv( nrhs, b( k, 1 ), ldb )
434 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
444 CALL zlacgv( nrhs, b( k, 1 ), ldb )
445 CALL zgemv(
'Conjugate transpose', n-k, nrhs, -one,
446 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
448 CALL zlacgv( nrhs, b( k, 1 ), ldb )
450 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
451 CALL zgemv(
'Conjugate transpose', n-k, nrhs, -one,
452 $ b( k+1, 1 ), ldb, ap( kc-( n-k ) ), 1, one,
454 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
461 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zhptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
ZHPTRS
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU