OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zsytrf_aa_2stage.f
Go to the documentation of this file.
1*> \brief \b ZSYTRF_AA_2STAGE
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download ZSYTRF_AA_2STAGE + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytrf_aa_2stage.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytrf_aa_2stage.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytrf_aa_2stage.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE ZSYTRF_AA_2STAGE( UPLO, N, A, LDA, TB, LTB, IPIV,
22* IPIV2, WORK, LWORK, INFO )
23*
24* .. Scalar Arguments ..
25* CHARACTER UPLO
26* INTEGER N, LDA, LTB, LWORK, INFO
27* ..
28* .. Array Arguments ..
29* INTEGER IPIV( * ), IPIV2( * )
30* COMPLEX*16 A( LDA, * ), TB( * ), WORK( * )
31* ..
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> ZSYTRF_AA_2STAGE computes the factorization of a complex symmetric matrix A
39*> using the Aasen's algorithm. The form of the factorization is
40*>
41*> A = U**T*T*U or A = L*T*L**T
42*>
43*> where U (or L) is a product of permutation and unit upper (lower)
44*> triangular matrices, and T is a complex symmetric band matrix with the
45*> bandwidth of NB (NB is internally selected and stored in TB( 1 ), and T is
46*> LU factorized with partial pivoting).
47*>
48*> This is the blocked version of the algorithm, calling Level 3 BLAS.
49*> \endverbatim
50*
51* Arguments:
52* ==========
53*
54*> \param[in] UPLO
55*> \verbatim
56*> UPLO is CHARACTER*1
57*> = 'U': Upper triangle of A is stored;
58*> = 'L': Lower triangle of A is stored.
59*> \endverbatim
60*>
61*> \param[in] N
62*> \verbatim
63*> N is INTEGER
64*> The order of the matrix A. N >= 0.
65*> \endverbatim
66*>
67*> \param[in,out] A
68*> \verbatim
69*> A is COMPLEX*16 array, dimension (LDA,N)
70*> On entry, the hermitian matrix A. If UPLO = 'U', the leading
71*> N-by-N upper triangular part of A contains the upper
72*> triangular part of the matrix A, and the strictly lower
73*> triangular part of A is not referenced. If UPLO = 'L', the
74*> leading N-by-N lower triangular part of A contains the lower
75*> triangular part of the matrix A, and the strictly upper
76*> triangular part of A is not referenced.
77*>
78*> On exit, L is stored below (or above) the subdiaonal blocks,
79*> when UPLO is 'L' (or 'U').
80*> \endverbatim
81*>
82*> \param[in] LDA
83*> \verbatim
84*> LDA is INTEGER
85*> The leading dimension of the array A. LDA >= max(1,N).
86*> \endverbatim
87*>
88*> \param[out] TB
89*> \verbatim
90*> TB is COMPLEX*16 array, dimension (LTB)
91*> On exit, details of the LU factorization of the band matrix.
92*> \endverbatim
93*>
94*> \param[in] LTB
95*> \verbatim
96*> LTB is INTEGER
97*> The size of the array TB. LTB >= 4*N, internally
98*> used to select NB such that LTB >= (3*NB+1)*N.
99*>
100*> If LTB = -1, then a workspace query is assumed; the
101*> routine only calculates the optimal size of LTB,
102*> returns this value as the first entry of TB, and
103*> no error message related to LTB is issued by XERBLA.
104*> \endverbatim
105*>
106*> \param[out] IPIV
107*> \verbatim
108*> IPIV is INTEGER array, dimension (N)
109*> On exit, it contains the details of the interchanges, i.e.,
110*> the row and column k of A were interchanged with the
111*> row and column IPIV(k).
112*> \endverbatim
113*>
114*> \param[out] IPIV2
115*> \verbatim
116*> IPIV2 is INTEGER array, dimension (N)
117*> On exit, it contains the details of the interchanges, i.e.,
118*> the row and column k of T were interchanged with the
119*> row and column IPIV(k).
120*> \endverbatim
121*>
122*> \param[out] WORK
123*> \verbatim
124*> WORK is COMPLEX*16 workspace of size LWORK
125*> \endverbatim
126*>
127*> \param[in] LWORK
128*> \verbatim
129*> LWORK is INTEGER
130*> The size of WORK. LWORK >= N, internally used to select NB
131*> such that LWORK >= N*NB.
132*>
133*> If LWORK = -1, then a workspace query is assumed; the
134*> routine only calculates the optimal size of the WORK array,
135*> returns this value as the first entry of the WORK array, and
136*> no error message related to LWORK is issued by XERBLA.
137*> \endverbatim
138*>
139*> \param[out] INFO
140*> \verbatim
141*> INFO is INTEGER
142*> = 0: successful exit
143*> < 0: if INFO = -i, the i-th argument had an illegal value.
144*> > 0: if INFO = i, band LU factorization failed on i-th column
145*> \endverbatim
146*
147* Authors:
148* ========
149*
150*> \author Univ. of Tennessee
151*> \author Univ. of California Berkeley
152*> \author Univ. of Colorado Denver
153*> \author NAG Ltd.
154*
155*> \ingroup complex16SYcomputational
156*
157* =====================================================================
158 SUBROUTINE zsytrf_aa_2stage( UPLO, N, A, LDA, TB, LTB, IPIV,
159 $ IPIV2, WORK, LWORK, INFO )
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*16 A( LDA, * ), TB( * ), WORK( * )
174* ..
175*
176* =====================================================================
177* .. Parameters ..
178 COMPLEX*16 CZERO, CONE
179 parameter( czero = ( 0.0d+0, 0.0d+0 ),
180 $ cone = ( 1.0d+0, 0.0d+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*16 PIV
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 INTEGER ILAENV
191 EXTERNAL lsame, ilaenv
192* ..
193* .. External Subroutines ..
194 EXTERNAL xerbla, zcopy, zgbtrf, zgemm, zgetrf,
195 $ zlacpy, zlaset, zlaswp, ztrsm, zswap
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( 'ZSYTRF_AA_2STAGE', -info )
222 RETURN
223 END IF
224*
225* Answer the query
226*
227 nb = ilaenv( 1, 'ZSYTRF_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 zgemm( '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 zgemm( '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 zlacpy( '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 zgemm( '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 zgemm( '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 zgemm( '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
345c CALL CHEGST( 1, 'Upper', KB,
346c $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1,
347c $ A( (J-1)*NB+1, J*NB+1 ), LDA, IINFO )
348 CALL ztrsm( '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 ztrsm( '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 zgemm( '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 zgemm( '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 zgemm( '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 ZGETRF
386*
387 DO k = 1, nb
388 CALL zcopy( 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 zgetrf( n-(j+1)*nb, nb,
396 $ work, n,
397 $ ipiv( (j+1)*nb+1 ), iinfo )
398c IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN
399c INFO = IINFO+(J+1)*NB
400c END IF
401*
402* Copy panel back
403*
404 DO k = 1, nb
405 CALL zcopy( 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 zlaset( 'Full', kb, nb, czero, czero,
414 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
415 CALL zlacpy( 'Upper', kb, nb,
416 $ work, n,
417 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
418 IF( j.GT.0 ) THEN
419 CALL ztrsm( '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 zlaset( '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.NE. IF( I1I2 ) THEN
445* > Apply pivots to previous columns of L
446 CALL ZSWAP( 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.GT. IF( I2(I1+1) )
450 $ CALL ZSWAP( 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.LT. IF( I2N )
454 $ CALL ZSWAP( 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.GT. IF( J0 ) THEN
462 CALL ZSWAP( 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.EQ. IF( I1 ) THEN
482* H(I,J) = T(I,I)*L(J,I)' + T(I+1,I)'*L(J,I+1)'
483.EQ. IF( I (J-1) ) THEN
484 JB = NB+KB
485 ELSE
486 JB = 2*NB
487 END IF
488 CALL ZGEMM( '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.EQ. IF( I (J-1) ) THEN
496 JB = 2*NB+KB
497 ELSE
498 JB = 3*NB
499 END IF
500 CALL ZGEMM( '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 ZLACPY( 'lower', KB, KB, A( J*NB+1, J*NB+1 ), LDA,
512 $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1 )
513.GT. IF( J1 ) THEN
514* T(J,J) = L(J,1:J)*H(1:J)
515 CALL ZGEMM( '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 ZGEMM( '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 ZGEMM( '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.GT. IF( J0 ) THEN
542c CALL CHEGST( 1, 'Lower', KB,
543c $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1,
544c $ A( J*NB+1, (J-1)*NB+1 ), LDA, IINFO )
545 CALL ZTRSM( '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 ZTRSM( '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.LT. IF( JNT-1 ) THEN
563.GT. IF( J0 ) THEN
564*
565* Compute H(J,J)
566*
567.EQ. IF( J1 ) THEN
568 CALL ZGEMM( '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 ZGEMM( '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 ZGEMM( '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 ZGETRF( N-(J+1)*NB, NB,
594 $ A( (J+1)*NB+1, J*NB+1 ), LDA,
595 $ IPIV( (J+1)*NB+1 ), IINFO )
596c IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN
597c INFO = IINFO+(J+1)*NB
598c 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 ZLASET( 'full', KB, NB, CZERO, CZERO,
604 $ TB( TD+NB+1 + (J*NB)*LDTB), LDTB-1 )
605 CALL ZLACPY( 'upper', KB, NB,
606 $ A( (J+1)*NB+1, J*NB+1 ), LDA,
607 $ TB( TD+NB+1 + (J*NB)*LDTB ), LDTB-1 )
608.GT. IF( J0 ) THEN
609 CALL ZTRSM( '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 ZLASET( '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.NE. IF( I1I2 ) THEN
635* > Apply pivots to previous columns of L
636 CALL ZSWAP( 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.GT. IF( I2(I1+1) )
640 $ CALL ZSWAP( 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.LT. IF( I2N )
644 $ CALL ZSWAP( 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.GT. IF( J0 ) THEN
652 CALL ZSWAP( 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*
660c CALL ZLASWP( J*NB, A( 1, 1 ), LDA,
661c $ (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 ZGBTRF( N, N, NB, NB, TB, LDTB, IPIV2, INFO )
668*
669 RETURN
670*
671* End of ZSYTRF_AA_2STAGE
672*
673 END
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
zgbtrf
subroutine zgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
ZGBTRF
Definition zgbtrf.f:144
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:103
zlaswp
subroutine zlaswp(n, a, lda, k1, k2, ipiv, incx)
ZLASWP performs a series of row interchanges on a general rectangular matrix.
Definition zlaswp.f:115
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:106
zsytrf_aa_2stage
subroutine zsytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
ZSYTRF_AA_2STAGE
Definition zsytrf_aa_2stage.f:160
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
zgetrf
subroutine zgetrf(m, n, a, lda, ipiv, info)
ZGETRF VARIANT: Crout Level 3 BLAS version of the algorithm.
Definition zgetrf.f:102
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21