155 SUBROUTINE dlavsy( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
164 CHARACTER DIAG, TRANS, UPLO
165 INTEGER INFO, LDA, LDB, N, NRHS
169 DOUBLE PRECISION A( lda, * ), B( ldb, * )
176 parameter ( one = 1.0d+0 )
181 DOUBLE PRECISION D11, D12, D21, D22, T1, T2
198 IF( .NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
200 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.
201 $ lsame( trans,
'T' ) .AND. .NOT.lsame( trans,
'C' ) )
THEN
203 ELSE IF( .NOT.lsame( diag,
'U' ) .AND. .NOT.lsame( diag,
'N' ) )
206 ELSE IF( n.LT.0 )
THEN
208 ELSE IF( lda.LT.max( 1, n ) )
THEN
210 ELSE IF( ldb.LT.max( 1, n ) )
THEN
214 CALL xerbla(
'DLAVSY ', -info )
223 nounit = lsame( diag,
'N' )
229 IF( lsame( trans,
'N' ) )
THEN
234 IF( lsame( uplo,
'U' ) )
THEN
242 IF( ipiv( k ).GT.0 )
THEN
249 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
257 CALL dger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
258 $ ldb, b( 1, 1 ), ldb )
264 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
281 b( k, j ) = d11*t1 + d12*t2
282 b( k+1, j ) = d21*t1 + d22*t2
292 CALL dger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
293 $ ldb, b( 1, 1 ), ldb )
294 CALL dger( k-1, nrhs, one, a( 1, k+1 ), 1,
295 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
299 kp = abs( ipiv( k ) )
301 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
323 IF( ipiv( k ).GT.0 )
THEN
330 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
339 CALL dger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
340 $ ldb, b( k+1, 1 ), ldb )
346 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
364 b( k-1, j ) = d11*t1 + d12*t2
365 b( k, j ) = d21*t1 + d22*t2
375 CALL dger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
376 $ ldb, b( k+1, 1 ), ldb )
377 CALL dger( n-k, nrhs, one, a( k+1, k-1 ), 1,
378 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
383 kp = abs( ipiv( k ) )
385 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
403 IF( lsame( uplo,
'U' ) )
THEN
414 IF( ipiv( k ).GT.0 )
THEN
421 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
425 CALL dgemv(
'Transpose', k-1, nrhs, one, b, ldb,
426 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
429 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
439 kp = abs( ipiv( k ) )
441 $
CALL dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
446 CALL dgemv(
'Transpose', k-2, nrhs, one, b, ldb,
447 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
448 CALL dgemv(
'Transpose', k-2, nrhs, one, b, ldb,
449 $ a( 1, k-1 ), 1, one, b( k-1, 1 ), ldb )
462 b( k-1, j ) = d11*t1 + d12*t2
463 b( k, j ) = d21*t1 + d22*t2
486 IF( ipiv( k ).GT.0 )
THEN
493 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
497 CALL dgemv(
'Transpose', n-k, nrhs, one, b( k+1, 1 ),
498 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
501 $
CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
511 kp = abs( ipiv( k ) )
513 $
CALL dswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
518 CALL dgemv(
'Transpose', n-k-1, nrhs, one,
519 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, one,
521 CALL dgemv(
'Transpose', n-k-1, nrhs, one,
522 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, one,
536 b( k, j ) = d11*t1 + d12*t2
537 b( k+1, j ) = d21*t1 + d22*t2
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
DGER
subroutine dlavsy(UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DLAVSY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL