129 SUBROUTINE zlavhp( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER INFO, LDB, N, NRHS
142 COMPLEX*16 A( * ), B( LDB, * )
149 parameter( one = ( 1.0d+0, 0.0d+0 ) )
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX*16 D11, D12, D21, D22, T1, T2
164 INTRINSIC abs, dconjg, max
171 IF( .NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
173 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.lsame( trans,
'C' ) )
176 ELSE IF( .NOT.lsame( diag,
'U' ) .AND. .NOT.lsame( diag,
'N' ) )
179 ELSE IF( n.LT.0 )
THEN
181 ELSE IF( ldb.LT.max( 1, n ) )
THEN
185 CALL xerbla(
'ZLAVHP ', -info )
194 nounit = lsame( diag,
'N' )
200 IF( lsame( trans,
'N' ) )
THEN
205 IF( lsame( uplo,
'U' ) )
THEN
217 IF( ipiv( k ).GT.0 )
THEN
222 $
CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
230 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
231 $ ldb, b( 1, 1 ), ldb )
237 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
252 d12 = a( kcnext+k-1 )
257 b( k, j ) = d11*t1 + d12*t2
258 b( k+1, j ) = d21*t1 + d22*t2
268 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL zgeru( k-1, nrhs, one, a( kcnext ), 1,
271 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
275 kp = abs( ipiv( k ) )
277 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
293 kc = n*( n+1 ) / 2 + 1
302 IF( ipiv( k ).GT.0 )
THEN
309 $
CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
318 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
319 $ ldb, b( k+1, 1 ), ldb )
325 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
333 kcnext = kc - ( n-k+2 )
345 b( k-1, j ) = d11*t1 + d12*t2
346 b( k, j ) = d21*t1 + d22*t2
356 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL zgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
359 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
364 kp = abs( ipiv( k ) )
366 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
385 IF( lsame( uplo,
'U' ) )
THEN
390 kc = n*( n+1 ) / 2 + 1
398 IF( ipiv( k ).GT.0 )
THEN
405 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
411 CALL zlacgv( nrhs, b( k, 1 ), ldb )
412 CALL zgemv(
'Conjugate', k-1, nrhs, one, b, ldb,
413 $ a( kc ), 1, one, b( k, 1 ), ldb )
414 CALL zlacgv( nrhs, b( k, 1 ), ldb )
417 $
CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
423 kcnext = kc - ( k-1 )
428 kp = abs( ipiv( k ) )
430 $
CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
435 CALL zlacgv( nrhs, b( k, 1 ), ldb )
436 CALL zgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
437 $ a( kc ), 1, one, b( k, 1 ), ldb )
438 CALL zlacgv( nrhs, b( k, 1 ), ldb )
440 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
441 CALL zgemv(
'Conjugate', k-2, nrhs, one, b, ldb,
442 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
443 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
456 b( k-1, j ) = d11*t1 + d12*t2
457 b( k, j ) = d21*t1 + d22*t2
482 IF( ipiv( k ).GT.0 )
THEN
489 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
493 CALL zlacgv( nrhs, b( k, 1 ), ldb )
494 CALL zgemv(
'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
495 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
496 CALL zlacgv( nrhs, b( k, 1 ), ldb )
499 $
CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
506 kcnext = kc + n - k + 1
511 kp = abs( ipiv( k ) )
513 $
CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
518 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
519 CALL zgemv(
'Conjugate', n-k-1, nrhs, one,
520 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
522 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
524 CALL zlacgv( nrhs, b( k, 1 ), ldb )
525 CALL zgemv(
'Conjugate', n-k-1, nrhs, one,
526 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
528 CALL zlacgv( nrhs, b( k, 1 ), ldb )
541 b( k, j ) = d11*t1 + d12*t2
542 b( k+1, j ) = d21*t1 + d22*t2
545 kc = kcnext + ( n-k )