153 SUBROUTINE dlavsy( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
161 CHARACTER DIAG, TRANS, UPLO
162 INTEGER INFO, LDA, LDB, N, NRHS
166 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
173 parameter( one = 1.0d+0 )
178 DOUBLE PRECISION D11, D12, D21, D22, T1, T2
195 IF( .NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
197 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.
198 $ lsame( trans,
'T' ) .AND. .NOT.lsame( trans,
'C' ) )
THEN
200 ELSE IF( .NOT.lsame( diag,
'U' ) .AND. .NOT.lsame( diag,
'N' ) )
203 ELSE IF( n.LT.0 )
THEN
205 ELSE IF( lda.LT.max( 1, n ) )
THEN
207 ELSE IF( ldb.LT.max( 1, n ) )
THEN
211 CALL xerbla(
'DLAVSY ', -info )
220 nounit = lsame( diag,
'N' )
226 IF( lsame( trans,
'N' ) )
THEN
231 IF( lsame( uplo,
'U' ) )
THEN
239 IF( ipiv( k ).GT.0 )
THEN
246 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
254 CALL dger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
255 $ ldb, b( 1, 1 ), ldb )
261 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
278 b( k, j ) = d11*t1 + d12*t2
279 b( k+1, j ) = d21*t1 + d22*t2
289 CALL dger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
290 $ ldb, b( 1, 1 ), ldb )
291 CALL dger( k-1, nrhs, one, a( 1, k+1 ), 1,
292 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
296 kp = abs( ipiv( k ) )
298 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
320 IF( ipiv( k ).GT.0 )
THEN
327 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
336 CALL dger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
337 $ ldb, b( k+1, 1 ), ldb )
343 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
361 b( k-1, j ) = d11*t1 + d12*t2
362 b( k, j ) = d21*t1 + d22*t2
372 CALL dger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
373 $ ldb, b( k+1, 1 ), ldb )
374 CALL dger( n-k, nrhs, one, a( k+1, k-1 ), 1,
375 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
380 kp = abs( ipiv( k ) )
382 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
400 IF( lsame( uplo,
'U' ) )
THEN
411 IF( ipiv( k ).GT.0 )
THEN
418 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
422 CALL dgemv(
'Transpose', k-1, nrhs, one, b, ldb,
423 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
426 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
436 kp = abs( ipiv( k ) )
438 $
CALL dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
443 CALL dgemv(
'Transpose', k-2, nrhs, one, b, ldb,
444 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
445 CALL dgemv(
'Transpose', k-2, nrhs, one, b, ldb,
446 $ a( 1, k-1 ), 1, one, b( k-1, 1 ), ldb )
459 b( k-1, j ) = d11*t1 + d12*t2
460 b( k, j ) = d21*t1 + d22*t2
483 IF( ipiv( k ).GT.0 )
THEN
490 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
494 CALL dgemv(
'Transpose', n-k, nrhs, one, b( k+1, 1 ),
495 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
498 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
508 kp = abs( ipiv( k ) )
510 $
CALL dswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
515 CALL dgemv(
'Transpose', n-k-1, nrhs, one,
516 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, one,
518 CALL dgemv(
'Transpose', n-k-1, nrhs, one,
519 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, one,
533 b( k, j ) = d11*t1 + d12*t2
534 b( k+1, j ) = d21*t1 + d22*t2