147 SUBROUTINE slaror( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
156 INTEGER info, lda, m, n
160 REAL a( lda, * ),
x( * )
166 REAL zero, one, toosml
167 parameter( zero = 0.0e+0, one = 1.0e+0,
171 INTEGER irow, itype, ixfrm,
j, jcol, kbeg, nxfrm
172 REAL factor, xnorm, xnorms
188 IF( n.EQ.0 .OR. m.EQ.0 )
192 IF(
lsame( side,
'L' ) )
THEN
194 ELSE IF(
lsame( side,
'R' ) )
THEN
196 ELSE IF(
lsame( side,
'C' ) .OR.
lsame( side,
'T' ) )
THEN
202 IF( itype.EQ.0 )
THEN
204 ELSE IF( m.LT.0 )
THEN
206 ELSE IF( n.LT.0 .OR. ( itype.EQ.3 .AND. n.NE.m ) )
THEN
208 ELSE IF( lda.LT.m )
THEN
212 CALL
xerbla(
'SLAROR', -info )
216 IF( itype.EQ.1 )
THEN
224 IF(
lsame( init,
'I' ) )
225 $ CALL
slaset(
'Full', m, n, zero, one, a, lda )
236 DO 30 ixfrm = 2, nxfrm
237 kbeg = nxfrm - ixfrm + 1
241 DO 20
j = kbeg, nxfrm
247 xnorm =
snrm2( ixfrm,
x( kbeg ), 1 )
248 xnorms = sign( xnorm,
x( kbeg ) )
249 x( kbeg+nxfrm ) = sign( one, -
x( kbeg ) )
250 factor = xnorms*( xnorms+
x( kbeg ) )
251 IF( abs( factor ).LT.toosml )
THEN
253 CALL
xerbla(
'SLAROR', info )
256 factor = one / factor
258 x( kbeg ) =
x( kbeg ) + xnorms
262 IF( itype.EQ.1 .OR. itype.EQ.3 )
THEN
266 CALL
sgemv(
'T', ixfrm, n, one, a( kbeg, 1 ), lda,
267 $
x( kbeg ), 1, zero,
x( 2*nxfrm+1 ), 1 )
268 CALL
sger( ixfrm, n, -factor,
x( kbeg ), 1,
x( 2*nxfrm+1 ),
269 $ 1, a( kbeg, 1 ), lda )
273 IF( itype.EQ.2 .OR. itype.EQ.3 )
THEN
277 CALL
sgemv(
'N', m, ixfrm, one, a( 1, kbeg ), lda,
278 $
x( kbeg ), 1, zero,
x( 2*nxfrm+1 ), 1 )
279 CALL
sger( m, ixfrm, -factor,
x( 2*nxfrm+1 ), 1,
x( kbeg ),
280 $ 1, a( 1, kbeg ), lda )
285 x( 2*nxfrm ) = sign( one,
slarnd( 3, iseed ) )
289 IF( itype.EQ.1 .OR. itype.EQ.3 )
THEN
291 CALL
sscal( n,
x( nxfrm+irow ), a( irow, 1 ), lda )
295 IF( itype.EQ.2 .OR. itype.EQ.3 )
THEN
297 CALL
sscal( m,
x( nxfrm+jcol ), a( 1, jcol ), 1 )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
LOGICAL function lsame(CA, CB)
LSAME
subroutine slaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
SLAROR
REAL function slarnd(IDIST, ISEED)
SLARND
subroutine xerbla(SRNAME, INFO)
XERBLA
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
REAL function snrm2(N, X, INCX)
SNRM2
subroutine sscal(N, SA, SX, INCX)
SSCAL