LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ zlahef_aa()

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

ZLAHEF_AA

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

Purpose: 
 DLAHEF_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 ZHETRF_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*16 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*16 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*16 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 zlahef_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*16 a( lda, * ), h( ldh, * ), work( * )
161 * ..
162 *
163 * =====================================================================
164 * .. Parameters ..
165  COMPLEX*16 zero, one
166  parameter( zero = (0.0d+0, 0.0d+0), one = (1.0d+0, 0.0d+0) )
167 *
168 * .. Local Scalars ..
169  INTEGER j, k, k1, i1, i2
170  COMPLEX*16 piv, alpha
171 * ..
172 * .. External Functions ..
173  LOGICAL lsame
174  INTEGER izamax, ilaenv
175  EXTERNAL lsame, ilaenv, izamax
176 * ..
177 * .. External Subroutines ..
178  EXTERNAL xerbla
179 * ..
180 * .. Intrinsic Functions ..
181  INTRINSIC dble, dconjg, 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 ZHETRF_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 zlacgv( j-k1, a( 1, j ), 1 )
221  CALL zgemv( '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 zlacgv( j-k1, a( 1, j ), 1 )
226  END IF
227 *
228 * Copy H(i:n, i) into WORK
229 *
230  CALL zcopy( 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 = -dconjg( a( k-1, j ) )
238  CALL zaxpy( 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 ) = dble( 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 zaxpy( 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 = izamax( 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 zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,
276  $ a( j1+i1, i2 ), 1 )
277  CALL zlacgv( i2-i1, a( j1+i1-1, i1+1 ), lda )
278  CALL zlacgv( 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 zswap( 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 zswap( 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 zswap( 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 zcopy( 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 zcopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
326  CALL zscal( m-j-1, alpha, a( k, j+2 ), lda )
327  ELSE
328  CALL zlaset( '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 ZHETRF_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 zlacgv( j-k1, a( j, 1 ), lda )
365  CALL zgemv( '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 zlacgv( j-k1, a( j, 1 ), lda )
370  END IF
371 *
372 * Copy H(J:N, J) into WORK
373 *
374  CALL zcopy( 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 = -dconjg( a( j, k-1 ) )
382  CALL zaxpy( 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 ) = dble( 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 zaxpy( 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 = izamax( 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 zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,
420  $ a( i2, j1+i1 ), lda )
421  CALL zlacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 )
422  CALL zlacgv( 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 zswap( 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 zswap( 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 zswap( 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 zcopy( 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 zcopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
470  CALL zscal( m-j-1, alpha, a( j+2, k ), 1 )
471  ELSE
472  CALL zlaset( '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 ZLAHEF_AA
483 *
zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:83
zgemv
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
Definition: zgemv.f:160
zswap
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
Definition: zswap.f:83
ilaenv
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
Definition: tstiee.f:83
izamax
integer function izamax(N, ZX, INCX)
IZAMAX
Definition: izamax.f:73
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
zlaset
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: zlaset.f:108
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
zlacgv
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
Definition: zlacgv.f:76
zaxpy
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
Definition: zaxpy.f:90
zscal
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
Definition: zscal.f:80
Here is the call graph for this function:
Here is the caller graph for this function: