159 SUBROUTINE claror( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
168 INTEGER info, lda, m, n
172 COMPLEX a( lda, * ),
x( * )
178 REAL zero, one, toosml
179 parameter( zero = 0.0e+0, one = 1.0e+0,
182 parameter( czero = ( 0.0e+0, 0.0e+0 ),
183 $ cone = ( 1.0e+0, 0.0e+0 ) )
186 INTEGER irow, itype, ixfrm,
j, jcol, kbeg, nxfrm
187 REAL factor, xabs, xnorm
188 COMPLEX csign, xnorms
200 INTRINSIC abs, cmplx, conjg
205 IF( n.EQ.0 .OR. m.EQ.0 )
209 IF(
lsame( side,
'L' ) )
THEN
211 ELSE IF(
lsame( side,
'R' ) )
THEN
213 ELSE IF(
lsame( side,
'C' ) )
THEN
215 ELSE IF(
lsame( side,
'T' ) )
THEN
221 IF( itype.EQ.0 )
THEN
223 ELSE IF( m.LT.0 )
THEN
225 ELSE IF( n.LT.0 .OR. ( itype.EQ.3 .AND. n.NE.m ) )
THEN
227 ELSE IF( lda.LT.m )
THEN
231 CALL
xerbla(
'CLAROR', -info )
235 IF( itype.EQ.1 )
THEN
243 IF(
lsame( init,
'I' ) )
244 $ CALL
claset(
'Full', m, n, czero, cone, a, lda )
257 DO 60 ixfrm = 2, nxfrm
258 kbeg = nxfrm - ixfrm + 1
262 DO 50
j = kbeg, nxfrm
268 xnorm =
scnrm2( ixfrm,
x( kbeg ), 1 )
269 xabs = abs(
x( kbeg ) )
270 IF( xabs.NE.czero )
THEN
271 csign =
x( kbeg ) / xabs
276 x( nxfrm+kbeg ) = -csign
277 factor = xnorm*( xnorm+xabs )
278 IF( abs( factor ).LT.toosml )
THEN
280 CALL
xerbla(
'CLAROR', -info )
283 factor = one / factor
285 x( kbeg ) =
x( kbeg ) + xnorms
289 IF( itype.EQ.1 .OR. itype.EQ.3 .OR. itype.EQ.4 )
THEN
293 CALL
cgemv(
'C', ixfrm, n, cone, a( kbeg, 1 ), lda,
294 $
x( kbeg ), 1, czero,
x( 2*nxfrm+1 ), 1 )
295 CALL
cgerc( ixfrm, n, -cmplx( factor ),
x( kbeg ), 1,
296 $
x( 2*nxfrm+1 ), 1, a( kbeg, 1 ), lda )
300 IF( itype.GE.2 .AND. itype.LE.4 )
THEN
304 IF( itype.EQ.4 )
THEN
305 CALL
clacgv( ixfrm,
x( kbeg ), 1 )
308 CALL
cgemv(
'N', m, ixfrm, cone, a( 1, kbeg ), lda,
309 $
x( kbeg ), 1, czero,
x( 2*nxfrm+1 ), 1 )
310 CALL
cgerc( m, ixfrm, -cmplx( factor ),
x( 2*nxfrm+1 ), 1,
311 $
x( kbeg ), 1, a( 1, kbeg ), lda )
318 IF( xabs.NE.zero )
THEN
319 csign =
x( 1 ) / xabs
327 IF( itype.EQ.1 .OR. itype.EQ.3 .OR. itype.EQ.4 )
THEN
329 CALL
cscal( n, conjg(
x( nxfrm+irow ) ), a( irow, 1 ), lda )
333 IF( itype.EQ.2 .OR. itype.EQ.3 )
THEN
335 CALL
cscal( m,
x( nxfrm+jcol ), a( 1, jcol ), 1 )
339 IF( itype.EQ.4 )
THEN
341 CALL
cscal( m, conjg(
x( nxfrm+jcol ) ), a( 1, jcol ), 1 )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
LOGICAL function lsame(CA, CB)
LSAME
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine claror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
CLAROR
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
COMPLEX function clarnd(IDIST, ISEED)
CLARND
REAL function scnrm2(N, X, INCX)
SCNRM2
subroutine cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERC