LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zhetrf_aa_2stage()

subroutine zhetrf_aa_2stage ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZHETRF_AA_2STAGE

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

Purpose:
!>
!> ZHETRF_AA_2STAGE computes the factorization of a double hermitian matrix A
!> using the Aasen's algorithm.  The form of the factorization is
!>
!>    A = U**H*T*U  or  A = L*T*L**H
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is a hermitian band matrix with the
!> bandwidth of NB (NB is internally selected and stored in TB( 1 ), and T is 
!> LU factorized with partial pivoting).
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the hermitian matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, L is stored below (or above) the subdiagonal blocks,
!>          when UPLO  is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX*16 array, dimension (MAX(1,LTB))
!>          On exit, details of the LU factorization of the band matrix.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= MAX(1,4*N), internally
!>          used to select NB such that LTB >= (3*NB+1)*N.
!>
!>          If LTB = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of LTB, 
!>          returns this value as the first entry of TB, and
!>          no error message related to LTB is issued by XERBLA.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of T were interchanged with the
!>          row and column IPIV(k).
!>
[out]WORK
!>          WORK is COMPLEX*16 workspace of size (MAX(1,LWORK))
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The size of WORK. LWORK >= MAX(1,N), internally used to
!>          select NB such that LWORK >= N*NB.
!>
!>          If LWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the WORK array,
!>          returns this value as the first entry of the WORK array, and
!>          no error message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, band LU factorization failed on i-th column
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 156 of file zhetrf_aa_2stage.f.

158*
159* -- LAPACK computational routine --
160* -- LAPACK is a software package provided by Univ. of Tennessee, --
161* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163 IMPLICIT NONE
164*
165* .. Scalar Arguments ..
166 CHARACTER UPLO
167 INTEGER N, LDA, LTB, LWORK, INFO
168* ..
169* .. Array Arguments ..
170 INTEGER IPIV( * ), IPIV2( * )
171 COMPLEX*16 A( LDA, * ), TB( * ), WORK( * )
172* ..
173*
174* =====================================================================
175* .. Parameters ..
176 COMPLEX*16 ZERO, ONE
177 parameter( zero = ( 0.0e+0, 0.0e+0 ),
178 $ one = ( 1.0e+0, 0.0e+0 ) )
179*
180* .. Local Scalars ..
181 LOGICAL UPPER, TQUERY, WQUERY
182 INTEGER I, J, K, I1, I2, TD
183 INTEGER LWKOPT, LDTB, NB, KB, JB, NT, IINFO
184 COMPLEX*16 PIV
185* ..
186* .. External Functions ..
187 LOGICAL LSAME
188 INTEGER ILAENV
189 EXTERNAL lsame, ilaenv
190* ..
191* .. External Subroutines ..
192 EXTERNAL xerbla, zcopy, zlacgv, zlacpy,
193 $ zlaset, zgbtrf, zgemm, zgetrf,
194 $ zhegst, zswap, ztrsm
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC dconjg, min, max
198* ..
199* .. Executable Statements ..
200*
201* Test the input parameters.
202*
203 info = 0
204 upper = lsame( uplo, 'U' )
205 wquery = ( lwork.EQ.-1 )
206 tquery = ( ltb.EQ.-1 )
207 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
208 info = -1
209 ELSE IF( n.LT.0 ) THEN
210 info = -2
211 ELSE IF( lda.LT.max( 1, n ) ) THEN
212 info = -4
213 ELSE IF( ltb.LT.max( 1, 4*n ) .AND. .NOT.tquery ) THEN
214 info = -6
215 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.wquery ) THEN
216 info = -10
217 END IF
218*
219 IF( info.NE.0 ) THEN
220 CALL xerbla( 'ZHETRF_AA_2STAGE', -info )
221 RETURN
222 END IF
223*
224* Answer the query
225*
226 nb = ilaenv( 1, 'ZHETRF_AA_2STAGE', uplo, n, -1, -1, -1 )
227 IF( info.EQ.0 ) THEN
228 IF( tquery ) THEN
229 tb( 1 ) = max( 1, (3*nb+1)*n )
230 END IF
231 IF( wquery ) THEN
232 work( 1 ) = max( 1, n*nb )
233 END IF
234 END IF
235 IF( tquery .OR. wquery ) THEN
236 RETURN
237 END IF
238*
239* Quick return
240*
241 IF( n.EQ.0 ) THEN
242 RETURN
243 ENDIF
244*
245* Determine the number of the block size
246*
247 ldtb = ltb/n
248 IF( ldtb .LT. 3*nb+1 ) THEN
249 nb = (ldtb-1)/3
250 END IF
251 IF( lwork .LT. nb*n ) THEN
252 nb = lwork/n
253 END IF
254*
255* Determine the number of the block columns
256*
257 nt = (n+nb-1)/nb
258 td = 2*nb
259 kb = min(nb, n)
260*
261* Initialize vectors/matrices
262*
263 DO j = 1, kb
264 ipiv( j ) = j
265 END DO
266*
267* Save NB
268*
269 tb( 1 ) = nb
270*
271 IF( upper ) THEN
272*
273* .....................................................
274* Factorize A as U**H*D*U using the upper triangle of A
275* .....................................................
276*
277 DO j = 0, nt-1
278*
279* Generate Jth column of W and H
280*
281 kb = min(nb, n-j*nb)
282 DO i = 1, j-1
283 IF( i.EQ.1 ) THEN
284* H(I,J) = T(I,I)*U(I,J) + T(I+1,I)*U(I+1,J)
285 IF( i .EQ. (j-1) ) THEN
286 jb = nb+kb
287 ELSE
288 jb = 2*nb
289 END IF
290 CALL zgemm( 'NoTranspose', 'NoTranspose',
291 $ nb, kb, jb,
292 $ one, tb( td+1 + (i*nb)*ldtb ), ldtb-1,
293 $ a( (i-1)*nb+1, j*nb+1 ), lda,
294 $ zero, work( i*nb+1 ), n )
295 ELSE
296* H(I,J) = T(I,I-1)*U(I-1,J) + T(I,I)*U(I,J) + T(I,I+1)*U(I+1,J)
297 IF( i .EQ. (j-1) ) THEN
298 jb = 2*nb+kb
299 ELSE
300 jb = 3*nb
301 END IF
302 CALL zgemm( 'NoTranspose', 'NoTranspose',
303 $ nb, kb, jb,
304 $ one, tb( td+nb+1 + ((i-1)*nb)*ldtb ),
305 $ ldtb-1,
306 $ a( (i-2)*nb+1, j*nb+1 ), lda,
307 $ zero, work( i*nb+1 ), n )
308 END IF
309 END DO
310*
311* Compute T(J,J)
312*
313 CALL zlacpy( 'Upper', kb, kb, a( j*nb+1, j*nb+1 ), lda,
314 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
315 IF( j.GT.1 ) THEN
316* T(J,J) = U(1:J,J)'*H(1:J)
317 CALL zgemm( 'Conjugate transpose', 'NoTranspose',
318 $ kb, kb, (j-1)*nb,
319 $ -one, a( 1, j*nb+1 ), lda,
320 $ work( nb+1 ), n,
321 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
322* T(J,J) += U(J,J)'*T(J,J-1)*U(J-1,J)
323 CALL zgemm( 'Conjugate transpose', 'NoTranspose',
324 $ kb, nb, kb,
325 $ one, a( (j-1)*nb+1, j*nb+1 ), lda,
326 $ tb( td+nb+1 + ((j-1)*nb)*ldtb ), ldtb-1,
327 $ zero, work( 1 ), n )
328 CALL zgemm( 'NoTranspose', 'NoTranspose',
329 $ kb, kb, nb,
330 $ -one, work( 1 ), n,
331 $ a( (j-2)*nb+1, j*nb+1 ), lda,
332 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
333 END IF
334 IF( j.GT.0 ) THEN
335 CALL zhegst( 1, 'Upper', kb,
336 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1,
337 $ a( (j-1)*nb+1, j*nb+1 ), lda, iinfo )
338 END IF
339*
340* Expand T(J,J) into full format
341*
342 DO i = 1, kb
343 tb( td+1 + (j*nb+i-1)*ldtb )
344 $ = real( tb( td+1 + (j*nb+i-1)*ldtb ) )
345 DO k = i+1, kb
346 tb( td+(k-i)+1 + (j*nb+i-1)*ldtb )
347 $ = dconjg( tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb ) )
348 END DO
349 END DO
350*
351 IF( j.LT.nt-1 ) THEN
352 IF( j.GT.0 ) THEN
353*
354* Compute H(J,J)
355*
356 IF( j.EQ.1 ) THEN
357 CALL zgemm( 'NoTranspose', 'NoTranspose',
358 $ kb, kb, kb,
359 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1,
360 $ a( (j-1)*nb+1, j*nb+1 ), lda,
361 $ zero, work( j*nb+1 ), n )
362 ELSE
363 CALL zgemm( 'NoTranspose', 'NoTranspose',
364 $ kb, kb, nb+kb,
365 $ one, tb( td+nb+1 + ((j-1)*nb)*ldtb ),
366 $ ldtb-1,
367 $ a( (j-2)*nb+1, j*nb+1 ), lda,
368 $ zero, work( j*nb+1 ), n )
369 END IF
370*
371* Update with the previous column
372*
373 CALL zgemm( 'Conjugate transpose', 'NoTranspose',
374 $ nb, n-(j+1)*nb, j*nb,
375 $ -one, work( nb+1 ), n,
376 $ a( 1, (j+1)*nb+1 ), lda,
377 $ one, a( j*nb+1, (j+1)*nb+1 ), lda )
378 END IF
379*
380* Copy panel to workspace to call ZGETRF
381*
382 DO k = 1, nb
383 CALL zcopy( n-(j+1)*nb,
384 $ a( j*nb+k, (j+1)*nb+1 ), lda,
385 $ work( 1+(k-1)*n ), 1 )
386 END DO
387*
388* Factorize panel
389*
390 CALL zgetrf( n-(j+1)*nb, nb,
391 $ work, n,
392 $ ipiv( (j+1)*nb+1 ), iinfo )
393c IF( IINFO.NE.0 .AND. INFO.EQ.0 ) THEN
394c INFO = IINFO+(J+1)*NB
395c END IF
396*
397* Copy panel back
398*
399 DO k = 1, nb
400*
401* Copy only L-factor
402*
403 CALL zcopy( n-k-(j+1)*nb,
404 $ work( k+1+(k-1)*n ), 1,
405 $ a( j*nb+k, (j+1)*nb+k+1 ), lda )
406*
407* Transpose U-factor to be copied back into T(J+1, J)
408*
409 CALL zlacgv( k, work( 1+(k-1)*n ), 1 )
410 END DO
411*
412* Compute T(J+1, J), zero out for GEMM update
413*
414 kb = min(nb, n-(j+1)*nb)
415 CALL zlaset( 'Full', kb, nb, zero, zero,
416 $ tb( td+nb+1 + (j*nb)*ldtb) , ldtb-1 )
417 CALL zlacpy( 'Upper', kb, nb,
418 $ work, n,
419 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
420 IF( j.GT.0 ) THEN
421 CALL ztrsm( 'R', 'U', 'N', 'U', kb, nb, one,
422 $ a( (j-1)*nb+1, j*nb+1 ), lda,
423 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
424 END IF
425*
426* Copy T(J,J+1) into T(J+1, J), both upper/lower for GEMM
427* updates
428*
429 DO k = 1, nb
430 DO i = 1, kb
431 tb( td-nb+k-i+1 + (j*nb+nb+i-1)*ldtb )
432 $ = dconjg( tb( td+nb+i-k+1 + (j*nb+k-1)*ldtb ) )
433 END DO
434 END DO
435 CALL zlaset( 'Lower', kb, nb, zero, one,
436 $ a( j*nb+1, (j+1)*nb+1), lda )
437*
438* Apply pivots to trailing submatrix of A
439*
440 DO k = 1, kb
441* > Adjust ipiv
442 ipiv( (j+1)*nb+k ) = ipiv( (j+1)*nb+k ) + (j+1)*nb
443*
444 i1 = (j+1)*nb+k
445 i2 = ipiv( (j+1)*nb+k )
446 IF( i1.NE.i2 ) THEN
447* > Apply pivots to previous columns of L
448 CALL zswap( k-1, a( (j+1)*nb+1, i1 ), 1,
449 $ a( (j+1)*nb+1, i2 ), 1 )
450* > Swap A(I1+1:M, I1) with A(I2, I1+1:M)
451 IF( i2.GT.(i1+1) ) THEN
452 CALL zswap( i2-i1-1, a( i1, i1+1 ), lda,
453 $ a( i1+1, i2 ), 1 )
454 CALL zlacgv( i2-i1-1, a( i1+1, i2 ), 1 )
455 END IF
456 CALL zlacgv( i2-i1, a( i1, i1+1 ), lda )
457* > Swap A(I2+1:M, I1) with A(I2+1:M, I2)
458 IF( i2.LT.n )
459 $ CALL zswap( n-i2, a( i1, i2+1 ), lda,
460 $ a( i2, i2+1 ), lda )
461* > Swap A(I1, I1) with A(I2, I2)
462 piv = a( i1, i1 )
463 a( i1, i1 ) = a( i2, i2 )
464 a( i2, i2 ) = piv
465* > Apply pivots to previous columns of L
466 IF( j.GT.0 ) THEN
467 CALL zswap( j*nb, a( 1, i1 ), 1,
468 $ a( 1, i2 ), 1 )
469 END IF
470 ENDIF
471 END DO
472 END IF
473 END DO
474 ELSE
475*
476* .....................................................
477* Factorize A as L*D*L**H using the lower triangle of A
478* .....................................................
479*
480 DO j = 0, nt-1
481*
482* Generate Jth column of W and H
483*
484 kb = min(nb, n-j*nb)
485 DO i = 1, j-1
486 IF( i.EQ.1 ) THEN
487* H(I,J) = T(I,I)*L(J,I)' + T(I+1,I)'*L(J,I+1)'
488 IF( i .EQ. (j-1) ) THEN
489 jb = nb+kb
490 ELSE
491 jb = 2*nb
492 END IF
493 CALL zgemm( 'NoTranspose', 'Conjugate transpose',
494 $ nb, kb, jb,
495 $ one, tb( td+1 + (i*nb)*ldtb ), ldtb-1,
496 $ a( j*nb+1, (i-1)*nb+1 ), lda,
497 $ zero, work( i*nb+1 ), n )
498 ELSE
499* H(I,J) = T(I,I-1)*L(J,I-1)' + T(I,I)*L(J,I)' + T(I,I+1)*L(J,I+1)'
500 IF( i .EQ. (j-1) ) THEN
501 jb = 2*nb+kb
502 ELSE
503 jb = 3*nb
504 END IF
505 CALL zgemm( 'NoTranspose', 'Conjugate transpose',
506 $ nb, kb, jb,
507 $ one, tb( td+nb+1 + ((i-1)*nb)*ldtb ),
508 $ ldtb-1,
509 $ a( j*nb+1, (i-2)*nb+1 ), lda,
510 $ zero, work( i*nb+1 ), n )
511 END IF
512 END DO
513*
514* Compute T(J,J)
515*
516 CALL zlacpy( 'Lower', kb, kb, a( j*nb+1, j*nb+1 ), lda,
517 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
518 IF( j.GT.1 ) THEN
519* T(J,J) = L(J,1:J)*H(1:J)
520 CALL zgemm( 'NoTranspose', 'NoTranspose',
521 $ kb, kb, (j-1)*nb,
522 $ -one, a( j*nb+1, 1 ), lda,
523 $ work( nb+1 ), n,
524 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
525* T(J,J) += L(J,J)*T(J,J-1)*L(J,J-1)'
526 CALL zgemm( 'NoTranspose', 'NoTranspose',
527 $ kb, nb, kb,
528 $ one, a( j*nb+1, (j-1)*nb+1 ), lda,
529 $ tb( td+nb+1 + ((j-1)*nb)*ldtb ), ldtb-1,
530 $ zero, work( 1 ), n )
531 CALL zgemm( 'NoTranspose', 'Conjugate transpose',
532 $ kb, kb, nb,
533 $ -one, work( 1 ), n,
534 $ a( j*nb+1, (j-2)*nb+1 ), lda,
535 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
536 END IF
537 IF( j.GT.0 ) THEN
538 CALL zhegst( 1, 'Lower', kb,
539 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1,
540 $ a( j*nb+1, (j-1)*nb+1 ), lda, iinfo )
541 END IF
542*
543* Expand T(J,J) into full format
544*
545 DO i = 1, kb
546 tb( td+1 + (j*nb+i-1)*ldtb )
547 $ = real( tb( td+1 + (j*nb+i-1)*ldtb ) )
548 DO k = i+1, kb
549 tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb )
550 $ = dconjg( tb( td+(k-i)+1 + (j*nb+i-1)*ldtb ) )
551 END DO
552 END DO
553*
554 IF( j.LT.nt-1 ) THEN
555 IF( j.GT.0 ) THEN
556*
557* Compute H(J,J)
558*
559 IF( j.EQ.1 ) THEN
560 CALL zgemm( 'NoTranspose',
561 $ 'Conjugate transpose',
562 $ kb, kb, kb,
563 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1,
564 $ a( j*nb+1, (j-1)*nb+1 ), lda,
565 $ zero, work( j*nb+1 ), n )
566 ELSE
567 CALL zgemm( 'NoTranspose',
568 $ 'Conjugate transpose',
569 $ kb, kb, nb+kb,
570 $ one, tb( td+nb+1 + ((j-1)*nb)*ldtb ),
571 $ ldtb-1,
572 $ a( j*nb+1, (j-2)*nb+1 ), lda,
573 $ zero, work( j*nb+1 ), n )
574 END IF
575*
576* Update with the previous column
577*
578 CALL zgemm( 'NoTranspose', 'NoTranspose',
579 $ n-(j+1)*nb, nb, j*nb,
580 $ -one, a( (j+1)*nb+1, 1 ), lda,
581 $ work( nb+1 ), n,
582 $ one, a( (j+1)*nb+1, j*nb+1 ), lda )
583 END IF
584*
585* Factorize panel
586*
587 CALL zgetrf( n-(j+1)*nb, nb,
588 $ a( (j+1)*nb+1, j*nb+1 ), lda,
589 $ ipiv( (j+1)*nb+1 ), iinfo )
590c IF( IINFO.NE.0 .AND. INFO.EQ.0 ) THEN
591c INFO = IINFO+(J+1)*NB
592c END IF
593*
594* Compute T(J+1, J), zero out for GEMM update
595*
596 kb = min(nb, n-(j+1)*nb)
597 CALL zlaset( 'Full', kb, nb, zero, zero,
598 $ tb( td+nb+1 + (j*nb)*ldtb) , ldtb-1 )
599 CALL zlacpy( 'Upper', kb, nb,
600 $ a( (j+1)*nb+1, j*nb+1 ), lda,
601 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
602 IF( j.GT.0 ) THEN
603 CALL ztrsm( 'R', 'L', 'C', 'U', kb, nb, one,
604 $ a( j*nb+1, (j-1)*nb+1 ), lda,
605 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
606 END IF
607*
608* Copy T(J+1,J) into T(J, J+1), both upper/lower for GEMM
609* updates
610*
611 DO k = 1, nb
612 DO i = 1, kb
613 tb( td-nb+k-i+1 + (j*nb+nb+i-1)*ldtb )
614 $ = dconjg( tb( td+nb+i-k+1 + (j*nb+k-1)*ldtb ) )
615 END DO
616 END DO
617 CALL zlaset( 'Upper', kb, nb, zero, one,
618 $ a( (j+1)*nb+1, j*nb+1), lda )
619*
620* Apply pivots to trailing submatrix of A
621*
622 DO k = 1, kb
623* > Adjust ipiv
624 ipiv( (j+1)*nb+k ) = ipiv( (j+1)*nb+k ) + (j+1)*nb
625*
626 i1 = (j+1)*nb+k
627 i2 = ipiv( (j+1)*nb+k )
628 IF( i1.NE.i2 ) THEN
629* > Apply pivots to previous columns of L
630 CALL zswap( k-1, a( i1, (j+1)*nb+1 ), lda,
631 $ a( i2, (j+1)*nb+1 ), lda )
632* > Swap A(I1+1:M, I1) with A(I2, I1+1:M)
633 IF( i2.GT.(i1+1) ) THEN
634 CALL zswap( i2-i1-1, a( i1+1, i1 ), 1,
635 $ a( i2, i1+1 ), lda )
636 CALL zlacgv( i2-i1-1, a( i2, i1+1 ), lda )
637 END IF
638 CALL zlacgv( i2-i1, a( i1+1, i1 ), 1 )
639* > Swap A(I2+1:M, I1) with A(I2+1:M, I2)
640 IF( i2.LT.n )
641 $ CALL zswap( n-i2, a( i2+1, i1 ), 1,
642 $ a( i2+1, i2 ), 1 )
643* > Swap A(I1, I1) with A(I2, I2)
644 piv = a( i1, i1 )
645 a( i1, i1 ) = a( i2, i2 )
646 a( i2, i2 ) = piv
647* > Apply pivots to previous columns of L
648 IF( j.GT.0 ) THEN
649 CALL zswap( j*nb, a( i1, 1 ), lda,
650 $ a( i2, 1 ), lda )
651 END IF
652 ENDIF
653 END DO
654*
655* Apply pivots to previous columns of L
656*
657c CALL ZLASWP( J*NB, A( 1, 1 ), LDA,
658c $ (J+1)*NB+1, (J+1)*NB+KB, IPIV, 1 )
659 END IF
660 END DO
661 END IF
662*
663* Factor the band matrix
664 CALL zgbtrf( n, n, nb, nb, tb, ldtb, ipiv2, info )
665*
666 RETURN
667*
668* End of ZHETRF_AA_2STAGE
669*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zgbtrf
subroutine zgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
ZGBTRF
Definition zgbtrf.f:142
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:188
zgetrf
subroutine zgetrf(m, n, a, lda, ipiv, info)
ZGETRF
Definition zgetrf.f:106
zhegst
subroutine zhegst(itype, uplo, n, a, lda, b, ldb, info)
ZHEGST
Definition zhegst.f:126
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:160
zlacgv
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
Definition zlacgv.f:72
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:101
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:104
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
Here is the call graph for this function:
Here is the caller graph for this function: