130 SUBROUTINE dlavsp( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
139 CHARACTER DIAG, TRANS, UPLO
140 INTEGER INFO, LDB, N, NRHS
144 DOUBLE PRECISION A( * ), B( ldb, * )
151 parameter ( one = 1.0d+0 )
155 INTEGER J, K, KC, KCNEXT, KP
156 DOUBLE PRECISION D11, D12, D21, D22, T1, T2
173 IF( .NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
175 ELSE IF( .NOT.lsame( trans,
'N' ) .AND. .NOT.
176 $ lsame( trans,
'T' ) .AND. .NOT.lsame( trans,
'C' ) )
THEN
178 ELSE IF( .NOT.lsame( diag,
'U' ) .AND. .NOT.lsame( diag,
'N' ) )
181 ELSE IF( n.LT.0 )
THEN
183 ELSE IF( ldb.LT.max( 1, n ) )
THEN
187 CALL xerbla(
'DLAVSP ', -info )
196 nounit = lsame( diag,
'N' )
202 IF( lsame( trans,
'N' ) )
THEN
207 IF( lsame( uplo,
'U' ) )
THEN
219 IF( ipiv( k ).GT.0 )
THEN
224 $
CALL dscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
232 CALL dger( k-1, nrhs, one, a( kc ), 1, b( k, 1 ), ldb,
239 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
254 d12 = a( kcnext+k-1 )
259 b( k, j ) = d11*t1 + d12*t2
260 b( k+1, j ) = d21*t1 + d22*t2
270 CALL dger( k-1, nrhs, one, a( kc ), 1, b( k, 1 ), ldb,
272 CALL dger( k-1, nrhs, one, a( kcnext ), 1,
273 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
277 kp = abs( ipiv( k ) )
279 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
295 kc = n*( n+1 ) / 2 + 1
304 IF( ipiv( k ).GT.0 )
THEN
311 $
CALL dscal( nrhs, a( kc ), b( k, 1 ), ldb )
320 CALL dger( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
321 $ ldb, b( k+1, 1 ), ldb )
327 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
335 kcnext = kc - ( n-k+2 )
347 b( k-1, j ) = d11*t1 + d12*t2
348 b( k, j ) = d21*t1 + d22*t2
358 CALL dger( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
359 $ ldb, b( k+1, 1 ), ldb )
360 CALL dger( n-k, nrhs, one, a( kcnext+2 ), 1,
361 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
366 kp = abs( ipiv( k ) )
368 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
387 IF( lsame( uplo,
'U' ) )
THEN
392 kc = n*( n+1 ) / 2 + 1
400 IF( ipiv( k ).GT.0 )
THEN
407 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
411 CALL dgemv(
'Transpose', k-1, nrhs, one, b, ldb,
412 $ a( kc ), 1, one, b( k, 1 ), ldb )
415 $
CALL dscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
421 kcnext = kc - ( k-1 )
426 kp = abs( ipiv( k ) )
428 $
CALL dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
433 CALL dgemv(
'Transpose', k-2, nrhs, one, b, ldb,
434 $ a( kc ), 1, one, b( k, 1 ), ldb )
435 CALL dgemv(
'Transpose', k-2, nrhs, one, b, ldb,
436 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
449 b( k-1, j ) = d11*t1 + d12*t2
450 b( k, j ) = d21*t1 + d22*t2
475 IF( ipiv( k ).GT.0 )
THEN
482 $
CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
486 CALL dgemv(
'Transpose', n-k, nrhs, one, b( k+1, 1 ),
487 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
490 $
CALL dscal( nrhs, a( kc ), b( k, 1 ), ldb )
497 kcnext = kc + n - k + 1
502 kp = abs( ipiv( k ) )
504 $
CALL dswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
509 CALL dgemv(
'Transpose', n-k-1, nrhs, one,
510 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
512 CALL dgemv(
'Transpose', n-k-1, nrhs, one,
513 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
527 b( k, j ) = d11*t1 + d12*t2
528 b( k+1, j ) = d21*t1 + d22*t2
531 kc = kcnext + ( n-k )
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 xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dlavsp(UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, INFO)
DLAVSP