131 SUBROUTINE zlavhp( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
140 CHARACTER DIAG, TRANS, UPLO
141 INTEGER INFO, LDB, N, NRHS
145 COMPLEX*16 A( * ), B( ldb, * )
152 parameter( one = ( 1.0d+0, 0.0d+0 ) )
156 INTEGER J, K, KC, KCNEXT, KP
157 COMPLEX*16 D11, D12, D21, D22, T1, T2
167 INTRINSIC abs, dconjg, max
174 IF( .NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
176 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.lsame( trans,
'C' ) )
179 ELSE IF( .NOT.lsame( diag,
'U' ) .AND. .NOT.lsame( diag,
'N' ) )
182 ELSE IF( n.LT.0 )
THEN
184 ELSE IF( ldb.LT.max( 1, n ) )
THEN
188 CALL
xerbla(
'ZLAVHP ', -info )
197 nounit = lsame( diag,
'N' )
203 IF( lsame( trans,
'N' ) )
THEN
208 IF( lsame( uplo,
'U' ) )
THEN
220 IF( ipiv( k ).GT.0 )
THEN
225 $ CALL
zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
233 CALL
zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
234 $ ldb, b( 1, 1 ), ldb )
240 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
255 d12 = a( kcnext+k-1 )
260 b( k, j ) = d11*t1 + d12*t2
261 b( k+1, j ) = d21*t1 + d22*t2
271 CALL
zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
272 $ ldb, b( 1, 1 ), ldb )
273 CALL
zgeru( k-1, nrhs, one, a( kcnext ), 1,
274 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
278 kp = abs( ipiv( k ) )
280 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
296 kc = n*( n+1 ) / 2 + 1
305 IF( ipiv( k ).GT.0 )
THEN
312 $ CALL
zscal( nrhs, a( kc ), b( k, 1 ), ldb )
321 CALL
zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
322 $ ldb, b( k+1, 1 ), ldb )
328 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
336 kcnext = kc - ( n-k+2 )
348 b( k-1, j ) = d11*t1 + d12*t2
349 b( k, j ) = d21*t1 + d22*t2
359 CALL
zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
360 $ ldb, b( k+1, 1 ), ldb )
361 CALL
zgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
362 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
367 kp = abs( ipiv( k ) )
369 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
388 IF( lsame( uplo,
'U' ) )
THEN
393 kc = n*( n+1 ) / 2 + 1
401 IF( ipiv( k ).GT.0 )
THEN
408 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
414 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
415 CALL
zgemv(
'Conjugate', k-1, nrhs, one, b, ldb,
416 $ a( kc ), 1, one, b( k, 1 ), ldb )
417 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
420 $ CALL
zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
426 kcnext = kc - ( k-1 )
431 kp = abs( ipiv( k ) )
433 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
438 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
439 CALL
zgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
440 $ a( kc ), 1, one, b( k, 1 ), ldb )
441 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
443 CALL
zlacgv( nrhs, b( k-1, 1 ), ldb )
444 CALL
zgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
445 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
446 CALL
zlacgv( nrhs, b( k-1, 1 ), ldb )
459 b( k-1, j ) = d11*t1 + d12*t2
460 b( k, j ) = d21*t1 + d22*t2
485 IF( ipiv( k ).GT.0 )
THEN
492 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
496 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
497 CALL
zgemv(
'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
498 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
499 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
502 $ CALL
zscal( nrhs, a( kc ), b( k, 1 ), ldb )
509 kcnext = kc + n - k + 1
514 kp = abs( ipiv( k ) )
516 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
521 CALL
zlacgv( nrhs, b( k+1, 1 ), ldb )
522 CALL
zgemv(
'Conjugate', n-k-1, nrhs, one,
523 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
525 CALL
zlacgv( nrhs, b( k+1, 1 ), ldb )
527 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
528 CALL
zgemv(
'Conjugate', n-k-1, nrhs, one,
529 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
531 CALL
zlacgv( nrhs, b( k, 1 ), ldb )
544 b( k, j ) = d11*t1 + d12*t2
545 b( k+1, j ) = d21*t1 + d22*t2
548 kc = kcnext + ( n-k )
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zlavhp(UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, INFO)
ZLAVHP
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU