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

◆ chetrf_aa_2stage()

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

CHETRF_AA_2STAGE

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

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