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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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