LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ clahef_aa()

subroutine clahef_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 
)

CLAHEF_AA

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

Purpose: 
 CLAHEF_AA factorizes a panel of a complex hermitian 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 CHETRF_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 COMPLEX 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,N).
[out]IPIV
          IPIV is INTEGER array, dimension (N)
          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 COMPLEX workspace, dimension (LDH,NB).
[in]LDH
          LDH is INTEGER
          The leading dimension of the workspace H. LDH >= max(1,M).
[out]WORK
          WORK is COMPLEX 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 clahef_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, 0.0e+0), one = (1.0e+0, 0.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 REAL, conjg, 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 CHETRF_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:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J),
210 * where H(J:N, J) has been initialized to be A(J, J:N)
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 clacgv( j-k1, a( 1, j ), 1 )
221  CALL cgemv( 'No transpose', m-j+1, j-k1,
222  $ -one, h( j, k1 ), ldh,
223  $ a( 1, j ), 1,
224  $ one, h( j, j ), 1 )
225  CALL clacgv( j-k1, a( 1, j ), 1 )
226  END IF
227 *
228 * Copy H(i:n, i) into WORK
229 *
230  CALL ccopy( m-j+1, h( j, j ), 1, work( 1 ), 1 )
231 *
232  IF( j.GT.k1 ) THEN
233 *
234 * Compute WORK := WORK - L(J-1, J:N) * T(J-1,J),
235 * where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N)
236 *
237  alpha = -conjg( a( k-1, j ) )
238  CALL caxpy( m-j+1, alpha, a( k-2, j ), lda, work( 1 ), 1 )
239  END IF
240 *
241 * Set A(J, J) = T(J, J)
242 *
243  a( k, j ) = REAL( WORK( 1 ) )
244 *
245  IF( j.LT.m ) THEN
246 *
247 * Compute WORK(2:N) = T(J, J) L(J, (J+1):N)
248 * where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N)
249 *
250  IF( k.GT.1 ) THEN
251  alpha = -a( k, j )
252  CALL caxpy( m-j, alpha, a( k-1, j+1 ), lda,
253  $ work( 2 ), 1 )
254  ENDIF
255 *
256 * Find max(|WORK(2:n)|)
257 *
258  i2 = icamax( m-j, work( 2 ), 1 ) + 1
259  piv = work( i2 )
260 *
261 * Apply hermitian pivot
262 *
263  IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
264 *
265 * Swap WORK(I1) and WORK(I2)
266 *
267  i1 = 2
268  work( i2 ) = work( i1 )
269  work( i1 ) = piv
270 *
271 * Swap A(I1, I1+1:N) with A(I1+1:N, I2)
272 *
273  i1 = i1+j-1
274  i2 = i2+j-1
275  CALL cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,
276  $ a( j1+i1, i2 ), 1 )
277  CALL clacgv( i2-i1, a( j1+i1-1, i1+1 ), lda )
278  CALL clacgv( i2-i1-1, a( j1+i1, i2 ), 1 )
279 *
280 * Swap A(I1, I2+1:N) with A(I2, I2+1:N)
281 *
282  CALL cswap( m-i2, a( j1+i1-1, i2+1 ), lda,
283  $ a( j1+i2-1, i2+1 ), lda )
284 *
285 * Swap A(I1, I1) with A(I2,I2)
286 *
287  piv = a( i1+j1-1, i1 )
288  a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
289  a( j1+i2-1, i2 ) = piv
290 *
291 * Swap H(I1, 1:J1) with H(I2, 1:J1)
292 *
293  CALL cswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
294  ipiv( i1 ) = i2
295 *
296  IF( i1.GT.(k1-1) ) THEN
297 *
298 * Swap L(1:I1-1, I1) with L(1:I1-1, I2),
299 * skipping the first column
300 *
301  CALL cswap( i1-k1+1, a( 1, i1 ), 1,
302  $ a( 1, i2 ), 1 )
303  END IF
304  ELSE
305  ipiv( j+1 ) = j+1
306  ENDIF
307 *
308 * Set A(J, J+1) = T(J, J+1)
309 *
310  a( k, j+1 ) = work( 2 )
311 *
312  IF( j.LT.nb ) THEN
313 *
314 * Copy A(J+1:N, J+1) into H(J:N, J),
315 *
316  CALL ccopy( m-j, a( k+1, j+1 ), lda,
317  $ h( j+1, j+1 ), 1 )
318  END IF
319 *
320 * Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1),
321 * where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1)
322 *
323  IF( a( k, j+1 ).NE.zero ) THEN
324  alpha = one / a( k, j+1 )
325  CALL ccopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
326  CALL cscal( m-j-1, alpha, a( k, j+2 ), lda )
327  ELSE
328  CALL claset( 'Full', 1, m-j-1, zero, zero,
329  $ a( k, j+2 ), lda)
330  END IF
331  END IF
332  j = j + 1
333  GO TO 10
334  20 CONTINUE
335 *
336  ELSE
337 *
338 * .....................................................
339 * Factorize A as L*D*L**T using the lower triangle of A
340 * .....................................................
341 *
342  30 CONTINUE
343  IF( j.GT.min( m, nb ) )
344  $ GO TO 40
345 *
346 * K is the column to be factorized
347 * when being called from CHETRF_AA,
348 * > for the first block column, J1 is 1, hence J1+J-1 is J,
349 * > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
350 *
351  k = j1+j-1
352 *
353 * H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T,
354 * where H(J:N, J) has been initialized to be A(J:N, J)
355 *
356  IF( k.GT.2 ) THEN
357 *
358 * K is the column to be factorized
359 * > for the first block column, K is J, skipping the first two
360 * columns
361 * > for the rest of the columns, K is J+1, skipping only the
362 * first column
363 *
364  CALL clacgv( j-k1, a( j, 1 ), lda )
365  CALL cgemv( 'No transpose', m-j+1, j-k1,
366  $ -one, h( j, k1 ), ldh,
367  $ a( j, 1 ), lda,
368  $ one, h( j, j ), 1 )
369  CALL clacgv( j-k1, a( j, 1 ), lda )
370  END IF
371 *
372 * Copy H(J:N, J) into WORK
373 *
374  CALL ccopy( m-j+1, h( j, j ), 1, work( 1 ), 1 )
375 *
376  IF( j.GT.k1 ) THEN
377 *
378 * Compute WORK := WORK - L(J:N, J-1) * T(J-1,J),
379 * where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1)
380 *
381  alpha = -conjg( a( j, k-1 ) )
382  CALL caxpy( m-j+1, alpha, a( j, k-2 ), 1, work( 1 ), 1 )
383  END IF
384 *
385 * Set A(J, J) = T(J, J)
386 *
387  a( j, k ) = REAL( WORK( 1 ) )
388 *
389  IF( j.LT.m ) THEN
390 *
391 * Compute WORK(2:N) = T(J, J) L((J+1):N, J)
392 * where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J)
393 *
394  IF( k.GT.1 ) THEN
395  alpha = -a( j, k )
396  CALL caxpy( m-j, alpha, a( j+1, k-1 ), 1,
397  $ work( 2 ), 1 )
398  ENDIF
399 *
400 * Find max(|WORK(2:n)|)
401 *
402  i2 = icamax( m-j, work( 2 ), 1 ) + 1
403  piv = work( i2 )
404 *
405 * Apply hermitian pivot
406 *
407  IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
408 *
409 * Swap WORK(I1) and WORK(I2)
410 *
411  i1 = 2
412  work( i2 ) = work( i1 )
413  work( i1 ) = piv
414 *
415 * Swap A(I1+1:N, I1) with A(I2, I1+1:N)
416 *
417  i1 = i1+j-1
418  i2 = i2+j-1
419  CALL cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,
420  $ a( i2, j1+i1 ), lda )
421  CALL clacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 )
422  CALL clacgv( i2-i1-1, a( i2, j1+i1 ), lda )
423 *
424 * Swap A(I2+1:N, I1) with A(I2+1:N, I2)
425 *
426  CALL cswap( m-i2, a( i2+1, j1+i1-1 ), 1,
427  $ a( i2+1, j1+i2-1 ), 1 )
428 *
429 * Swap A(I1, I1) with A(I2, I2)
430 *
431  piv = a( i1, j1+i1-1 )
432  a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
433  a( i2, j1+i2-1 ) = piv
434 *
435 * Swap H(I1, I1:J1) with H(I2, I2:J1)
436 *
437  CALL cswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
438  ipiv( i1 ) = i2
439 *
440  IF( i1.GT.(k1-1) ) THEN
441 *
442 * Swap L(1:I1-1, I1) with L(1:I1-1, I2),
443 * skipping the first column
444 *
445  CALL cswap( i1-k1+1, a( i1, 1 ), lda,
446  $ a( i2, 1 ), lda )
447  END IF
448  ELSE
449  ipiv( j+1 ) = j+1
450  ENDIF
451 *
452 * Set A(J+1, J) = T(J+1, J)
453 *
454  a( j+1, k ) = work( 2 )
455 *
456  IF( j.LT.nb ) THEN
457 *
458 * Copy A(J+1:N, J+1) into H(J+1:N, J),
459 *
460  CALL ccopy( m-j, a( j+1, k+1 ), 1,
461  $ h( j+1, j+1 ), 1 )
462  END IF
463 *
464 * Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1),
465 * where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1)
466 *
467  IF( a( j+1, k ).NE.zero ) THEN
468  alpha = one / a( j+1, k )
469  CALL ccopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
470  CALL cscal( m-j-1, alpha, a( j+2, k ), 1 )
471  ELSE
472  CALL claset( 'Full', m-j-1, 1, zero, zero,
473  $ a( j+2, k ), lda )
474  END IF
475  END IF
476  j = j + 1
477  GO TO 30
478  40 CONTINUE
479  END IF
480  RETURN
481 *
482 * End of CLAHEF_AA
483 *
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
clacgv
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
Definition: clacgv.f:76
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: