LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ dlasyf_aa()

subroutine dlasyf_aa ( character  UPLO,
integer  J1,
integer  M,
integer  NB,
double precision, dimension( lda, * )  A,
integer  LDA,
integer, dimension( * )  IPIV,
double precision, dimension( ldh, * )  H,
integer  LDH,
double precision, dimension( * )  WORK 
)

DLASYF_AA

Download DLASYF_AA + dependencies [TGZ] [ZIP] [TXT]

Purpose: 
 DLATRF_AA factorizes a panel of a real symmetric matrix A using
 the Aasen's algorithm. The panel consists of a set of NB rows of A
 when UPLO is U, or a set of NB columns when UPLO is L.

 In order to factorize the panel, the Aasen's algorithm requires the
 last row, or column, of the previous panel. The first row, or column,
 of A is set to be the first row, or column, of an identity matrix,
 which is used to factorize the first panel.

 The resulting J-th row of U, or J-th column of L, is stored in the
 (J-1)-th row, or column, of A (without the unit diagonals), while
 the diagonal and subdiagonal of A are overwritten by those of T.
Parameters
[in]UPLO
          UPLO is CHARACTER*1
          = 'U':  Upper triangle of A is stored;
          = 'L':  Lower triangle of A is stored.
[in]J1
          J1 is INTEGER
          The location of the first row, or column, of the panel
          within the submatrix of A, passed to this routine, e.g.,
          when called by DSYTRF_AA, for the first panel, J1 is 1,
          while for the remaining panels, J1 is 2.
[in]M
          M is INTEGER
          The dimension of the submatrix. M >= 0.
[in]NB
          NB is INTEGER
          The dimension of the panel to be facotorized.
[in,out]A
          A is DOUBLE PRECISION array, dimension (LDA,M) for
          the first panel, while dimension (LDA,M+1) for the
          remaining panels.

          On entry, A contains the last row, or column, of
          the previous panel, and the trailing submatrix of A
          to be factorized, except for the first panel, only
          the panel is passed.

          On exit, the leading panel is factorized.
[in]LDA
          LDA is INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).
[out]IPIV
          IPIV is INTEGER array, dimension (M)
          Details of the row and column interchanges,
          the row and column k were interchanged with the row and
          column IPIV(k).
[in,out]H
          H is DOUBLE PRECISION workspace, dimension (LDH,NB).
[in]LDH
          LDH is INTEGER
          The leading dimension of the workspace H. LDH >= max(1,M).
[out]WORK
          WORK is DOUBLE PRECISION workspace, dimension (M).
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
June 2017

Definition at line 146 of file dlasyf_aa.f.

146 *
147 * -- LAPACK computational routine (version 3.7.1) --
148 * -- LAPACK is a software package provided by Univ. of Tennessee, --
149 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
150 * June 2017
151 *
152  IMPLICIT NONE
153 *
154 * .. Scalar Arguments ..
155  CHARACTER uplo
156  INTEGER m, nb, j1, lda, ldh
157 * ..
158 * .. Array Arguments ..
159  INTEGER ipiv( * )
160  DOUBLE PRECISION a( lda, * ), h( ldh, * ), work( * )
161 * ..
162 *
163 * =====================================================================
164 * .. Parameters ..
165  DOUBLE PRECISION zero, one
166  parameter( zero = 0.0d+0, one = 1.0d+0 )
167 *
168 * .. Local Scalars ..
169  INTEGER j, k, k1, i1, i2
170  DOUBLE PRECISION piv, alpha
171 * ..
172 * .. External Functions ..
173  LOGICAL lsame
174  INTEGER idamax, ilaenv
175  EXTERNAL lsame, ilaenv, idamax
176 * ..
177 * .. External Subroutines ..
178  EXTERNAL xerbla
179 * ..
180 * .. Intrinsic Functions ..
181  INTRINSIC max
182 * ..
183 * .. Executable Statements ..
184 *
185  j = 1
186 *
187 * K1 is the first column of the panel to be factorized
188 * i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks
189 *
190  k1 = (2-j1)+1
191 *
192  IF( lsame( uplo, 'U' ) ) THEN
193 *
194 * .....................................................
195 * Factorize A as U**T*D*U using the upper triangle of A
196 * .....................................................
197 *
198  10 CONTINUE
199  IF ( j.GT.min(m, nb) )
200  $ GO TO 20
201 *
202 * K is the column to be factorized
203 * when being called from DSYTRF_AA,
204 * > for the first block column, J1 is 1, hence J1+J-1 is J,
205 * > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
206 *
207  k = j1+j-1
208 *
209 * H(J:M, J) := A(J, J:M) - H(J:M, 1:(J-1)) * L(J1:(J-1), J),
210 * where H(J:M, J) has been initialized to be A(J, J:M)
211 *
212  IF( k.GT.2 ) THEN
213 *
214 * K is the column to be factorized
215 * > for the first block column, K is J, skipping the first two
216 * columns
217 * > for the rest of the columns, K is J+1, skipping only the
218 * first column
219 *
220  CALL dgemv( 'No transpose', m-j+1, j-k1,
221  $ -one, h( j, k1 ), ldh,
222  $ a( 1, j ), 1,
223  $ one, h( j, j ), 1 )
224  END IF
225 *
226 * Copy H(i:M, i) into WORK
227 *
228  CALL dcopy( m-j+1, h( j, j ), 1, work( 1 ), 1 )
229 *
230  IF( j.GT.k1 ) THEN
231 *
232 * Compute WORK := WORK - L(J-1, J:M) * T(J-1,J),
233 * where A(J-1, J) stores T(J-1, J) and A(J-2, J:M) stores U(J-1, J:M)
234 *
235  alpha = -a( k-1, j )
236  CALL daxpy( m-j+1, alpha, a( k-2, j ), lda, work( 1 ), 1 )
237  END IF
238 *
239 * Set A(J, J) = T(J, J)
240 *
241  a( k, j ) = work( 1 )
242 *
243  IF( j.LT.m ) THEN
244 *
245 * Compute WORK(2:M) = T(J, J) L(J, (J+1):M)
246 * where A(J, J) stores T(J, J) and A(J-1, (J+1):M) stores U(J, (J+1):M)
247 *
248  IF( k.GT.1 ) THEN
249  alpha = -a( k, j )
250  CALL daxpy( m-j, alpha, a( k-1, j+1 ), lda,
251  $ work( 2 ), 1 )
252  ENDIF
253 *
254 * Find max(|WORK(2:M)|)
255 *
256  i2 = idamax( m-j, work( 2 ), 1 ) + 1
257  piv = work( i2 )
258 *
259 * Apply symmetric pivot
260 *
261  IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
262 *
263 * Swap WORK(I1) and WORK(I2)
264 *
265  i1 = 2
266  work( i2 ) = work( i1 )
267  work( i1 ) = piv
268 *
269 * Swap A(I1, I1+1:M) with A(I1+1:M, I2)
270 *
271  i1 = i1+j-1
272  i2 = i2+j-1
273  CALL dswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,
274  $ a( j1+i1, i2 ), 1 )
275 *
276 * Swap A(I1, I2+1:M) with A(I2, I2+1:M)
277 *
278  CALL dswap( m-i2, a( j1+i1-1, i2+1 ), lda,
279  $ a( j1+i2-1, i2+1 ), lda )
280 *
281 * Swap A(I1, I1) with A(I2,I2)
282 *
283  piv = a( i1+j1-1, i1 )
284  a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
285  a( j1+i2-1, i2 ) = piv
286 *
287 * Swap H(I1, 1:J1) with H(I2, 1:J1)
288 *
289  CALL dswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
290  ipiv( i1 ) = i2
291 *
292  IF( i1.GT.(k1-1) ) THEN
293 *
294 * Swap L(1:I1-1, I1) with L(1:I1-1, I2),
295 * skipping the first column
296 *
297  CALL dswap( i1-k1+1, a( 1, i1 ), 1,
298  $ a( 1, i2 ), 1 )
299  END IF
300  ELSE
301  ipiv( j+1 ) = j+1
302  ENDIF
303 *
304 * Set A(J, J+1) = T(J, J+1)
305 *
306  a( k, j+1 ) = work( 2 )
307 *
308  IF( j.LT.nb ) THEN
309 *
310 * Copy A(J+1:M, J+1) into H(J:M, J),
311 *
312  CALL dcopy( m-j, a( k+1, j+1 ), lda,
313  $ h( j+1, j+1 ), 1 )
314  END IF
315 *
316 * Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1),
317 * where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1)
318 *
319  IF( a( k, j+1 ).NE.zero ) THEN
320  alpha = one / a( k, j+1 )
321  CALL dcopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
322  CALL dscal( m-j-1, alpha, a( k, j+2 ), lda )
323  ELSE
324  CALL dlaset( 'Full', 1, m-j-1, zero, zero,
325  $ a( k, j+2 ), lda)
326  END IF
327  END IF
328  j = j + 1
329  GO TO 10
330  20 CONTINUE
331 *
332  ELSE
333 *
334 * .....................................................
335 * Factorize A as L*D*L**T using the lower triangle of A
336 * .....................................................
337 *
338  30 CONTINUE
339  IF( j.GT.min( m, nb ) )
340  $ GO TO 40
341 *
342 * K is the column to be factorized
343 * when being called from DSYTRF_AA,
344 * > for the first block column, J1 is 1, hence J1+J-1 is J,
345 * > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
346 *
347  k = j1+j-1
348 *
349 * H(J:M, J) := A(J:M, J) - H(J:M, 1:(J-1)) * L(J, J1:(J-1))^T,
350 * where H(J:M, J) has been initialized to be A(J:M, J)
351 *
352  IF( k.GT.2 ) THEN
353 *
354 * K is the column to be factorized
355 * > for the first block column, K is J, skipping the first two
356 * columns
357 * > for the rest of the columns, K is J+1, skipping only the
358 * first column
359 *
360  CALL dgemv( 'No transpose', m-j+1, j-k1,
361  $ -one, h( j, k1 ), ldh,
362  $ a( j, 1 ), lda,
363  $ one, h( j, j ), 1 )
364  END IF
365 *
366 * Copy H(J:M, J) into WORK
367 *
368  CALL dcopy( m-j+1, h( j, j ), 1, work( 1 ), 1 )
369 *
370  IF( j.GT.k1 ) THEN
371 *
372 * Compute WORK := WORK - L(J:M, J-1) * T(J-1,J),
373 * where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1)
374 *
375  alpha = -a( j, k-1 )
376  CALL daxpy( m-j+1, alpha, a( j, k-2 ), 1, work( 1 ), 1 )
377  END IF
378 *
379 * Set A(J, J) = T(J, J)
380 *
381  a( j, k ) = work( 1 )
382 *
383  IF( j.LT.m ) THEN
384 *
385 * Compute WORK(2:M) = T(J, J) L((J+1):M, J)
386 * where A(J, J) = T(J, J) and A((J+1):M, J-1) = L((J+1):M, J)
387 *
388  IF( k.GT.1 ) THEN
389  alpha = -a( j, k )
390  CALL daxpy( m-j, alpha, a( j+1, k-1 ), 1,
391  $ work( 2 ), 1 )
392  ENDIF
393 *
394 * Find max(|WORK(2:M)|)
395 *
396  i2 = idamax( m-j, work( 2 ), 1 ) + 1
397  piv = work( i2 )
398 *
399 * Apply symmetric pivot
400 *
401  IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
402 *
403 * Swap WORK(I1) and WORK(I2)
404 *
405  i1 = 2
406  work( i2 ) = work( i1 )
407  work( i1 ) = piv
408 *
409 * Swap A(I1+1:M, I1) with A(I2, I1+1:M)
410 *
411  i1 = i1+j-1
412  i2 = i2+j-1
413  CALL dswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,
414  $ a( i2, j1+i1 ), lda )
415 *
416 * Swap A(I2+1:M, I1) with A(I2+1:M, I2)
417 *
418  CALL dswap( m-i2, a( i2+1, j1+i1-1 ), 1,
419  $ a( i2+1, j1+i2-1 ), 1 )
420 *
421 * Swap A(I1, I1) with A(I2, I2)
422 *
423  piv = a( i1, j1+i1-1 )
424  a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
425  a( i2, j1+i2-1 ) = piv
426 *
427 * Swap H(I1, I1:J1) with H(I2, I2:J1)
428 *
429  CALL dswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
430  ipiv( i1 ) = i2
431 *
432  IF( i1.GT.(k1-1) ) THEN
433 *
434 * Swap L(1:I1-1, I1) with L(1:I1-1, I2),
435 * skipping the first column
436 *
437  CALL dswap( i1-k1+1, a( i1, 1 ), lda,
438  $ a( i2, 1 ), lda )
439  END IF
440  ELSE
441  ipiv( j+1 ) = j+1
442  ENDIF
443 *
444 * Set A(J+1, J) = T(J+1, J)
445 *
446  a( j+1, k ) = work( 2 )
447 *
448  IF( j.LT.nb ) THEN
449 *
450 * Copy A(J+1:M, J+1) into H(J+1:M, J),
451 *
452  CALL dcopy( m-j, a( j+1, k+1 ), 1,
453  $ h( j+1, j+1 ), 1 )
454  END IF
455 *
456 * Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1),
457 * where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1)
458 *
459  IF( a( j+1, k ).NE.zero ) THEN
460  alpha = one / a( j+1, k )
461  CALL dcopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
462  CALL dscal( m-j-1, alpha, a( j+2, k ), 1 )
463  ELSE
464  CALL dlaset( 'Full', m-j-1, 1, zero, zero,
465  $ a( j+2, k ), lda )
466  END IF
467  END IF
468  j = j + 1
469  GO TO 30
470  40 CONTINUE
471  END IF
472  RETURN
473 *
474 * End of DLASYF_AA
475 *
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:84
idamax
integer function idamax(N, DX, INCX)
IDAMAX
Definition: idamax.f:73
dgemv
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
Definition: dgemv.f:158
daxpy
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
Definition: daxpy.f:91
dlaset
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: dlaset.f:112
ilaenv
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
Definition: tstiee.f:83
dswap
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
Definition: dswap.f:84
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
dscal
subroutine dscal(N, DA, DX, INCX)
DSCAL
Definition: dscal.f:81
Here is the call graph for this function:
Here is the caller graph for this function: