LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ csytrf_aa_2stage()

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

CSYTRF_AA_2STAGE

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

Purpose:
 CSYTRF_AA_2STAGE computes the factorization of a complex symmetric 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 complex symmetric 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 subdiaonal 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 (LTB)
          On exit, details of the LU factorization of the band matrix.
[in]LTB
          LTB is INTEGER
          The size of the array TB. LTB >= 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 LWORK
[in]LWORK
          LWORK is INTEGER
          The size of WORK. LWORK >= 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 158 of file csytrf_aa_2stage.f.

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