1: SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )
2: *
3: * -- LAPACK routine (version 3.2) --
4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6: * November 2006
7: *
8: * .. Scalar Arguments ..
9: CHARACTER UPLO
10: INTEGER INFO, N
11: * ..
12: * .. Array Arguments ..
13: INTEGER IPIV( * )
14: COMPLEX*16 AP( * )
15: * ..
16: *
17: * Purpose
18: * =======
19: *
20: * ZSPTRF computes the factorization of a complex symmetric matrix A
21: * stored in packed format using the Bunch-Kaufman diagonal pivoting
22: * method:
23: *
24: * A = U*D*U**T or A = L*D*L**T
25: *
26: * where U (or L) is a product of permutation and unit upper (lower)
27: * triangular matrices, and D is symmetric and block diagonal with
28: * 1-by-1 and 2-by-2 diagonal blocks.
29: *
30: * Arguments
31: * =========
32: *
33: * UPLO (input) CHARACTER*1
34: * = 'U': Upper triangle of A is stored;
35: * = 'L': Lower triangle of A is stored.
36: *
37: * N (input) INTEGER
38: * The order of the matrix A. N >= 0.
39: *
40: * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
41: * On entry, the upper or lower triangle of the symmetric matrix
42: * A, packed columnwise in a linear array. The j-th column of A
43: * is stored in the array AP as follows:
44: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
45: * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
46: *
47: * On exit, the block diagonal matrix D and the multipliers used
48: * to obtain the factor U or L, stored as a packed triangular
49: * matrix overwriting A (see below for further details).
50: *
51: * IPIV (output) INTEGER array, dimension (N)
52: * Details of the interchanges and the block structure of D.
53: * If IPIV(k) > 0, then rows and columns k and IPIV(k) were
54: * interchanged and D(k,k) is a 1-by-1 diagonal block.
55: * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
56: * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
57: * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
58: * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
59: * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
60: *
61: * INFO (output) INTEGER
62: * = 0: successful exit
63: * < 0: if INFO = -i, the i-th argument had an illegal value
64: * > 0: if INFO = i, D(i,i) is exactly zero. The factorization
65: * has been completed, but the block diagonal matrix D is
66: * exactly singular, and division by zero will occur if it
67: * is used to solve a system of equations.
68: *
69: * Further Details
70: * ===============
71: *
72: * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
73: * Company
74: *
75: * If UPLO = 'U', then A = U*D*U', where
76: * U = P(n)*U(n)* ... *P(k)U(k)* ...,
77: * i.e., U is a product of terms P(k)*U(k), where k decreases from n to
78: * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
79: * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
80: * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
81: * that if the diagonal block D(k) is of order s (s = 1 or 2), then
82: *
83: * ( I v 0 ) k-s
84: * U(k) = ( 0 I 0 ) s
85: * ( 0 0 I ) n-k
86: * k-s s n-k
87: *
88: * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
89: * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
90: * and A(k,k), and v overwrites A(1:k-2,k-1:k).
91: *
92: * If UPLO = 'L', then A = L*D*L', where
93: * L = P(1)*L(1)* ... *P(k)*L(k)* ...,
94: * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
95: * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
96: * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
97: * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
98: * that if the diagonal block D(k) is of order s (s = 1 or 2), then
99: *
100: * ( I 0 0 ) k-1
101: * L(k) = ( 0 I 0 ) s
102: * ( 0 v I ) n-k-s+1
103: * k-1 s n-k-s+1
104: *
105: * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
106: * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
107: * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
108: *
109: * =====================================================================
110: *
111: * .. Parameters ..
112: DOUBLE PRECISION ZERO, ONE
113: PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
114: DOUBLE PRECISION EIGHT, SEVTEN
115: PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
116: COMPLEX*16 CONE
117: PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
118: * ..
119: * .. Local Scalars ..
120: LOGICAL UPPER
121: INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
122: $ KSTEP, KX, NPP
123: DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX
124: COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM
125: * ..
126: * .. External Functions ..
127: LOGICAL LSAME
128: INTEGER IZAMAX
129: EXTERNAL LSAME, IZAMAX
130: * ..
131: * .. External Subroutines ..
132: EXTERNAL XERBLA, ZSCAL, ZSPR, ZSWAP
133: * ..
134: * .. Intrinsic Functions ..
135: INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT
136: * ..
137: * .. Statement Functions ..
138: DOUBLE PRECISION CABS1
139: * ..
140: * .. Statement Function definitions ..
141: CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
142: * ..
143: * .. Executable Statements ..
144: *
145: * Test the input parameters.
146: *
147: INFO = 0
148: UPPER = LSAME( UPLO, 'U' )
149: IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
150: INFO = -1
151: ELSE IF( N.LT.0 ) THEN
152: INFO = -2
153: END IF
154: IF( INFO.NE.0 ) THEN
155: CALL XERBLA( 'ZSPTRF', -INFO )
156: RETURN
157: END IF
158: *
159: * Initialize ALPHA for use in choosing pivot block size.
160: *
161: ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
162: *
163: IF( UPPER ) THEN
164: *
165: * Factorize A as U*D*U' using the upper triangle of A
166: *
167: * K is the main loop index, decreasing from N to 1 in steps of
168: * 1 or 2
169: *
170: K = N
171: KC = ( N-1 )*N / 2 + 1
172: 10 CONTINUE
173: KNC = KC
174: *
175: * If K < 1, exit from loop
176: *
177: IF( K.LT.1 )
178: $ GO TO 110
179: KSTEP = 1
180: *
181: * Determine rows and columns to be interchanged and whether
182: * a 1-by-1 or 2-by-2 pivot block will be used
183: *
184: ABSAKK = CABS1( AP( KC+K-1 ) )
185: *
186: * IMAX is the row-index of the largest off-diagonal element in
187: * column K, and COLMAX is its absolute value
188: *
189: IF( K.GT.1 ) THEN
190: IMAX = IZAMAX( K-1, AP( KC ), 1 )
191: COLMAX = CABS1( AP( KC+IMAX-1 ) )
192: ELSE
193: COLMAX = ZERO
194: END IF
195: *
196: IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
197: *
198: * Column K is zero: set INFO and continue
199: *
200: IF( INFO.EQ.0 )
201: $ INFO = K
202: KP = K
203: ELSE
204: IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
205: *
206: * no interchange, use 1-by-1 pivot block
207: *
208: KP = K
209: ELSE
210: *
211: * JMAX is the column-index of the largest off-diagonal
212: * element in row IMAX, and ROWMAX is its absolute value
213: *
214: ROWMAX = ZERO
215: JMAX = IMAX
216: KX = IMAX*( IMAX+1 ) / 2 + IMAX
217: DO 20 J = IMAX + 1, K
218: IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
219: ROWMAX = CABS1( AP( KX ) )
220: JMAX = J
221: END IF
222: KX = KX + J
223: 20 CONTINUE
224: KPC = ( IMAX-1 )*IMAX / 2 + 1
225: IF( IMAX.GT.1 ) THEN
226: JMAX = IZAMAX( IMAX-1, AP( KPC ), 1 )
227: ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-1 ) ) )
228: END IF
229: *
230: IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
231: *
232: * no interchange, use 1-by-1 pivot block
233: *
234: KP = K
235: ELSE IF( CABS1( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
236: *
237: * interchange rows and columns K and IMAX, use 1-by-1
238: * pivot block
239: *
240: KP = IMAX
241: ELSE
242: *
243: * interchange rows and columns K-1 and IMAX, use 2-by-2
244: * pivot block
245: *
246: KP = IMAX
247: KSTEP = 2
248: END IF
249: END IF
250: *
251: KK = K - KSTEP + 1
252: IF( KSTEP.EQ.2 )
253: $ KNC = KNC - K + 1
254: IF( KP.NE.KK ) THEN
255: *
256: * Interchange rows and columns KK and KP in the leading
257: * submatrix A(1:k,1:k)
258: *
259: CALL ZSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
260: KX = KPC + KP - 1
261: DO 30 J = KP + 1, KK - 1
262: KX = KX + J - 1
263: T = AP( KNC+J-1 )
264: AP( KNC+J-1 ) = AP( KX )
265: AP( KX ) = T
266: 30 CONTINUE
267: T = AP( KNC+KK-1 )
268: AP( KNC+KK-1 ) = AP( KPC+KP-1 )
269: AP( KPC+KP-1 ) = T
270: IF( KSTEP.EQ.2 ) THEN
271: T = AP( KC+K-2 )
272: AP( KC+K-2 ) = AP( KC+KP-1 )
273: AP( KC+KP-1 ) = T
274: END IF
275: END IF
276: *
277: * Update the leading submatrix
278: *
279: IF( KSTEP.EQ.1 ) THEN
280: *
281: * 1-by-1 pivot block D(k): column k now holds
282: *
283: * W(k) = U(k)*D(k)
284: *
285: * where U(k) is the k-th column of U
286: *
287: * Perform a rank-1 update of A(1:k-1,1:k-1) as
288: *
289: * A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
290: *
291: R1 = CONE / AP( KC+K-1 )
292: CALL ZSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
293: *
294: * Store U(k) in column k
295: *
296: CALL ZSCAL( K-1, R1, AP( KC ), 1 )
297: ELSE
298: *
299: * 2-by-2 pivot block D(k): columns k and k-1 now hold
300: *
301: * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
302: *
303: * where U(k) and U(k-1) are the k-th and (k-1)-th columns
304: * of U
305: *
306: * Perform a rank-2 update of A(1:k-2,1:k-2) as
307: *
308: * A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
309: * = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
310: *
311: IF( K.GT.2 ) THEN
312: *
313: D12 = AP( K-1+( K-1 )*K / 2 )
314: D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
315: D11 = AP( K+( K-1 )*K / 2 ) / D12
316: T = CONE / ( D11*D22-CONE )
317: D12 = T / D12
318: *
319: DO 50 J = K - 2, 1, -1
320: WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
321: $ AP( J+( K-1 )*K / 2 ) )
322: WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
323: $ AP( J+( K-2 )*( K-1 ) / 2 ) )
324: DO 40 I = J, 1, -1
325: AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
326: $ AP( I+( K-1 )*K / 2 )*WK -
327: $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
328: 40 CONTINUE
329: AP( J+( K-1 )*K / 2 ) = WK
330: AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
331: 50 CONTINUE
332: *
333: END IF
334: END IF
335: END IF
336: *
337: * Store details of the interchanges in IPIV
338: *
339: IF( KSTEP.EQ.1 ) THEN
340: IPIV( K ) = KP
341: ELSE
342: IPIV( K ) = -KP
343: IPIV( K-1 ) = -KP
344: END IF
345: *
346: * Decrease K and return to the start of the main loop
347: *
348: K = K - KSTEP
349: KC = KNC - K
350: GO TO 10
351: *
352: ELSE
353: *
354: * Factorize A as L*D*L' using the lower triangle of A
355: *
356: * K is the main loop index, increasing from 1 to N in steps of
357: * 1 or 2
358: *
359: K = 1
360: KC = 1
361: NPP = N*( N+1 ) / 2
362: 60 CONTINUE
363: KNC = KC
364: *
365: * If K > N, exit from loop
366: *
367: IF( K.GT.N )
368: $ GO TO 110
369: KSTEP = 1
370: *
371: * Determine rows and columns to be interchanged and whether
372: * a 1-by-1 or 2-by-2 pivot block will be used
373: *
374: ABSAKK = CABS1( AP( KC ) )
375: *
376: * IMAX is the row-index of the largest off-diagonal element in
377: * column K, and COLMAX is its absolute value
378: *
379: IF( K.LT.N ) THEN
380: IMAX = K + IZAMAX( N-K, AP( KC+1 ), 1 )
381: COLMAX = CABS1( AP( KC+IMAX-K ) )
382: ELSE
383: COLMAX = ZERO
384: END IF
385: *
386: IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
387: *
388: * Column K is zero: set INFO and continue
389: *
390: IF( INFO.EQ.0 )
391: $ INFO = K
392: KP = K
393: ELSE
394: IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
395: *
396: * no interchange, use 1-by-1 pivot block
397: *
398: KP = K
399: ELSE
400: *
401: * JMAX is the column-index of the largest off-diagonal
402: * element in row IMAX, and ROWMAX is its absolute value
403: *
404: ROWMAX = ZERO
405: KX = KC + IMAX - K
406: DO 70 J = K, IMAX - 1
407: IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
408: ROWMAX = CABS1( AP( KX ) )
409: JMAX = J
410: END IF
411: KX = KX + N - J
412: 70 CONTINUE
413: KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
414: IF( IMAX.LT.N ) THEN
415: JMAX = IMAX + IZAMAX( N-IMAX, AP( KPC+1 ), 1 )
416: ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-IMAX ) ) )
417: END IF
418: *
419: IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
420: *
421: * no interchange, use 1-by-1 pivot block
422: *
423: KP = K
424: ELSE IF( CABS1( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
425: *
426: * interchange rows and columns K and IMAX, use 1-by-1
427: * pivot block
428: *
429: KP = IMAX
430: ELSE
431: *
432: * interchange rows and columns K+1 and IMAX, use 2-by-2
433: * pivot block
434: *
435: KP = IMAX
436: KSTEP = 2
437: END IF
438: END IF
439: *
440: KK = K + KSTEP - 1
441: IF( KSTEP.EQ.2 )
442: $ KNC = KNC + N - K + 1
443: IF( KP.NE.KK ) THEN
444: *
445: * Interchange rows and columns KK and KP in the trailing
446: * submatrix A(k:n,k:n)
447: *
448: IF( KP.LT.N )
449: $ CALL ZSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ),
450: $ 1 )
451: KX = KNC + KP - KK
452: DO 80 J = KK + 1, KP - 1
453: KX = KX + N - J + 1
454: T = AP( KNC+J-KK )
455: AP( KNC+J-KK ) = AP( KX )
456: AP( KX ) = T
457: 80 CONTINUE
458: T = AP( KNC )
459: AP( KNC ) = AP( KPC )
460: AP( KPC ) = T
461: IF( KSTEP.EQ.2 ) THEN
462: T = AP( KC+1 )
463: AP( KC+1 ) = AP( KC+KP-K )
464: AP( KC+KP-K ) = T
465: END IF
466: END IF
467: *
468: * Update the trailing submatrix
469: *
470: IF( KSTEP.EQ.1 ) THEN
471: *
472: * 1-by-1 pivot block D(k): column k now holds
473: *
474: * W(k) = L(k)*D(k)
475: *
476: * where L(k) is the k-th column of L
477: *
478: IF( K.LT.N ) THEN
479: *
480: * Perform a rank-1 update of A(k+1:n,k+1:n) as
481: *
482: * A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
483: *
484: R1 = CONE / AP( KC )
485: CALL ZSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
486: $ AP( KC+N-K+1 ) )
487: *
488: * Store L(k) in column K
489: *
490: CALL ZSCAL( N-K, R1, AP( KC+1 ), 1 )
491: END IF
492: ELSE
493: *
494: * 2-by-2 pivot block D(k): columns K and K+1 now hold
495: *
496: * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
497: *
498: * where L(k) and L(k+1) are the k-th and (k+1)-th columns
499: * of L
500: *
501: IF( K.LT.N-1 ) THEN
502: *
503: * Perform a rank-2 update of A(k+2:n,k+2:n) as
504: *
505: * A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
506: * = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
507: *
508: * where L(k) and L(k+1) are the k-th and (k+1)-th
509: * columns of L
510: *
511: D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
512: D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
513: D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
514: T = CONE / ( D11*D22-CONE )
515: D21 = T / D21
516: *
517: DO 100 J = K + 2, N
518: WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
519: $ AP( J+K*( 2*N-K-1 ) / 2 ) )
520: WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
521: $ AP( J+( K-1 )*( 2*N-K ) / 2 ) )
522: DO 90 I = J, N
523: AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
524: $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
525: $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
526: 90 CONTINUE
527: AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
528: AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
529: 100 CONTINUE
530: END IF
531: END IF
532: END IF
533: *
534: * Store details of the interchanges in IPIV
535: *
536: IF( KSTEP.EQ.1 ) THEN
537: IPIV( K ) = KP
538: ELSE
539: IPIV( K ) = -KP
540: IPIV( K+1 ) = -KP
541: END IF
542: *
543: * Increase K and return to the start of the main loop
544: *
545: K = K + KSTEP
546: KC = KNC + N - K + 2
547: GO TO 60
548: *
549: END IF
550: *
551: 110 CONTINUE
552: RETURN
553: *
554: * End of ZSPTRF
555: *
556: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zsptrf.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack