LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ clasyf_aa()

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

CLASYF_AA

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

Purpose: 
 DLATRF_AA factorizes a panel of a complex 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 CSYTRF_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 REAL 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 REAL workspace, dimension (LDH,NB).
[in]LDH
          LDH is INTEGER
          The leading dimension of the workspace H. LDH >= max(1,M).
[out]WORK
          WORK is REAL 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 clasyf_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  COMPLEX a( lda, * ), h( ldh, * ), work( * )
161 * ..
162 *
163 * =====================================================================
164 * .. Parameters ..
165  COMPLEX zero, one
166  parameter( zero = 0.0e+0, one = 1.0e+0 )
167 *
168 * .. Local Scalars ..
169  INTEGER j, k, k1, i1, i2
170  COMPLEX piv, alpha
171 * ..
172 * .. External Functions ..
173  LOGICAL lsame
174  INTEGER icamax, ilaenv
175  EXTERNAL lsame, ilaenv, icamax
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 CSYTRF_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 cgemv( '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 ccopy( 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 caxpy( 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 caxpy( 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 = icamax( 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 cswap( 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 cswap( 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 cswap( 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 cswap( 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 ccopy( 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 ccopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
322  CALL cscal( m-j-1, alpha, a( k, j+2 ), lda )
323  ELSE
324  CALL claset( '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 CSYTRF_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 cgemv( '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 ccopy( 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 caxpy( 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 caxpy( 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 = icamax( 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 cswap( 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 cswap( 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 cswap( 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 cswap( 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 ccopy( 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 ccopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
462  CALL cscal( m-j-1, alpha, a( j+2, k ), 1 )
463  ELSE
464  CALL claset( '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 CLASYF_AA
475 *
icamax
integer function icamax(N, CX, INCX)
ICAMAX
Definition: icamax.f:73
claset
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...
Definition: claset.f:108
ilaenv
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
Definition: tstiee.f:83
cscal
subroutine cscal(N, CA, CX, INCX)
CSCAL
Definition: cscal.f:80
cgemv
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
Definition: cgemv.f:160
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
ccopy
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
cswap
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
Definition: cswap.f:83
caxpy
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
Definition: caxpy.f:90
Here is the call graph for this function:
Here is the caller graph for this function: