166 SUBROUTINE dlaeda( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
167 $ givcol, givnum, q, qptr, z, ztemp, info )
175 INTEGER CURLVL, CURPBM, INFO, N, TLVLS
178 INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
179 $ prmptr( * ), qptr( * )
180 DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
186 DOUBLE PRECISION ZERO, HALF, ONE
187 parameter ( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
190 INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
197 INTRINSIC dble, int, sqrt
209 CALL xerbla(
'DLAEDA', -info )
229 curr = ptr + curpbm*2**curlvl + 2**( curlvl-1 ) - 1
235 bsiz1 = int( half+sqrt( dble( qptr( curr+1 )-qptr( curr ) ) ) )
236 bsiz2 = int( half+sqrt( dble( qptr( curr+2 )-qptr( curr+1 ) ) ) )
237 DO 10 k = 1, mid - bsiz1 - 1
240 CALL dcopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,
241 $ z( mid-bsiz1 ), 1 )
242 CALL dcopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1 )
243 DO 20 k = mid + bsiz2, n
252 DO 70 k = 1, curlvl - 1
253 curr = ptr + curpbm*2**( curlvl-k ) + 2**( curlvl-k-1 ) - 1
254 psiz1 = prmptr( curr+1 ) - prmptr( curr )
255 psiz2 = prmptr( curr+2 ) - prmptr( curr+1 )
260 DO 30 i = givptr( curr ), givptr( curr+1 ) - 1
261 CALL drot( 1, z( zptr1+givcol( 1, i )-1 ), 1,
262 $ z( zptr1+givcol( 2, i )-1 ), 1, givnum( 1, i ),
265 DO 40 i = givptr( curr+1 ), givptr( curr+2 ) - 1
266 CALL drot( 1, z( mid-1+givcol( 1, i ) ), 1,
267 $ z( mid-1+givcol( 2, i ) ), 1, givnum( 1, i ),
270 psiz1 = prmptr( curr+1 ) - prmptr( curr )
271 psiz2 = prmptr( curr+2 ) - prmptr( curr+1 )
272 DO 50 i = 0, psiz1 - 1
273 ztemp( i+1 ) = z( zptr1+perm( prmptr( curr )+i )-1 )
275 DO 60 i = 0, psiz2 - 1
276 ztemp( psiz1+i+1 ) = z( mid+perm( prmptr( curr+1 )+i )-1 )
285 bsiz1 = int( half+sqrt( dble( qptr( curr+1 )-qptr( curr ) ) ) )
286 bsiz2 = int( half+sqrt( dble( qptr( curr+2 )-qptr( curr+
288 IF( bsiz1.GT.0 )
THEN
289 CALL dgemv(
'T', bsiz1, bsiz1, one, q( qptr( curr ) ),
290 $ bsiz1, ztemp( 1 ), 1, zero, z( zptr1 ), 1 )
292 CALL dcopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),
294 IF( bsiz2.GT.0 )
THEN
295 CALL dgemv(
'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),
296 $ bsiz2, ztemp( psiz1+1 ), 1, zero, z( mid ), 1 )
298 CALL dcopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,
299 $ z( mid+bsiz2 ), 1 )
301 ptr = ptr + 2**( tlvls-k )
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlaeda(N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO)
DLAEDA used by sstedc. Computes the Z vector determining the rank-one modification of the diagonal ma...
subroutine xerbla(SRNAME, INFO)
XERBLA