130 SUBROUTINE slavsp( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
139 CHARACTER DIAG, TRANS, UPLO
140 INTEGER INFO, LDB, N, NRHS
144 REAL A( * ), B( ldb, * )
151 parameter( one = 1.0e+0 )
155 INTEGER J, K, KC, KCNEXT, KP
156 REAL 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(
'SLAVSP ', -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
sscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
232 CALL
sger( k-1, nrhs, one, a( kc ), 1, b( k, 1 ), ldb,
239 $ CALL
sswap( 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
sger( k-1, nrhs, one, a( kc ), 1, b( k, 1 ), ldb,
272 CALL
sger( k-1, nrhs, one, a( kcnext ), 1,
273 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
277 kp = abs( ipiv( k ) )
279 $ CALL
sswap( 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
sscal( nrhs, a( kc ), b( k, 1 ), ldb )
320 CALL
sger( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
321 $ ldb, b( k+1, 1 ), ldb )
327 $ CALL
sswap( 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
sger( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
359 $ ldb, b( k+1, 1 ), ldb )
360 CALL
sger( 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
sswap( 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
sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
411 CALL
sgemv(
'Transpose', k-1, nrhs, one, b, ldb,
412 $ a( kc ), 1, one, b( k, 1 ), ldb )
415 $ CALL
sscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
421 kcnext = kc - ( k-1 )
426 kp = abs( ipiv( k ) )
428 $ CALL
sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
433 CALL
sgemv(
'Transpose', k-2, nrhs, one, b, ldb,
434 $ a( kc ), 1, one, b( k, 1 ), ldb )
435 CALL
sgemv(
'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
sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
486 CALL
sgemv(
'Transpose', n-k, nrhs, one, b( k+1, 1 ),
487 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
490 $ CALL
sscal( nrhs, a( kc ), b( k, 1 ), ldb )
497 kcnext = kc + n - k + 1
502 kp = abs( ipiv( k ) )
504 $ CALL
sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
509 CALL
sgemv(
'Transpose', n-k-1, nrhs, one,
510 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
512 CALL
sgemv(
'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 sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
subroutine slavsp(UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, INFO)
SLAVSP
subroutine sscal(N, SA, SX, INCX)
SSCAL