1 SUBROUTINE slagsy( N, K, D, A, LDA, ISEED, WORK, INFO )
8 INTEGER INFO, K, LDA, N
12 REAL A( LDA, * ), D( * ), WORK( * )
59 parameter( zero = 0.0e+0, one = 1.0e+0, half = 0.5e+0 )
63 REAL ALPHA, TAU, WA, WB, WN
66 EXTERNAL saxpy, sgemv, sger, slarnv, sscal, ssymv,
83 ELSE IF( k.LT.0 .OR. k.GT.n-1 )
THEN
85 ELSE IF( lda.LT.
max( 1, n ) )
THEN
89 CALL xerbla(
'SLAGSY', -info )
106 DO 40 i = n - 1, 1, -1
110 CALL slarnv( 3, iseed, n-i+1, work )
111 wn = snrm2( n-i+1, work, 1 )
112 wa = sign( wn, work( 1 ) )
113 IF( wn.EQ.zero )
THEN
117 CALL sscal( n-i, one / wb, work( 2 ), 1 )
127 CALL ssymv(
'Lower', n-i+1, tau, a( i, i ), lda, work, 1, zero,
132 alpha = -half*tau*sdot( n-i+1, work( n+1 ), 1, work, 1 )
133 CALL saxpy( n-i+1, alpha, work, 1, work( n+1 ), 1 )
137 CALL ssyr2(
'Lower', n-i+1, -one, work, 1, work( n+1 ), 1,
143 DO 60 i = 1, n - 1 - k
147 wn = snrm2( n-k-i+1, a( k+i, i ), 1 )
148 wa = sign( wn, a( k+i, i ) )
149 IF( wn.EQ.zero )
THEN
152 wb = a( k+i, i ) + wa
153 CALL sscal( n-k-i, one / wb, a( k+i+1, i ), 1 )
160 CALL sgemv(
'Transpose', n-k-i+1, k-1, one, a( k+i, i+1 ), lda,
161 $ a( k+i, i ), 1, zero, work, 1 )
162 CALL sger( n-k-i+1, k-1, -tau, a( k+i, i ), 1, work, 1,
163 $ a( k+i, i+1 ), lda )
169 CALL ssymv(
'Lower', n-k-i+1, tau, a( k+i, k+i ), lda,
170 $ a( k+i, i ), 1, zero, work, 1 )
174 alpha = -half*tau*sdot( n-k-i+1, work, 1, a( k+i, i ), 1 )
175 CALL saxpy( n-k-i+1, alpha, a( k+i, i ), 1, work, 1 )
179 CALL ssyr2(
'Lower', n-k-i+1, -one, a( k+i, i ), 1, work, 1,
180 $ a( k+i, k+i ), lda )
183 DO 50 j = k + i + 1, n
192 a( j, i ) = a( i, j )