Annotation of rpl/lapack/lapack/dlasyf.f, revision 1.16
1.14 bertrand 1: *> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
1.9 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.14 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.9 bertrand 7: *
8: *> \htmlonly
1.14 bertrand 9: *> Download DLASYF + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasyf.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasyf.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasyf.f">
1.9 bertrand 15: *> [TXT]</a>
1.14 bertrand 16: *> \endhtmlonly
1.9 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
1.14 bertrand 22: *
1.9 bertrand 23: * .. Scalar Arguments ..
24: * CHARACTER UPLO
25: * INTEGER INFO, KB, LDA, LDW, N, NB
26: * ..
27: * .. Array Arguments ..
28: * INTEGER IPIV( * )
29: * DOUBLE PRECISION A( LDA, * ), W( LDW, * )
30: * ..
1.14 bertrand 31: *
1.9 bertrand 32: *
33: *> \par Purpose:
34: * =============
35: *>
36: *> \verbatim
37: *>
38: *> DLASYF computes a partial factorization of a real symmetric matrix A
39: *> using the Bunch-Kaufman diagonal pivoting method. The partial
40: *> factorization has the form:
41: *>
42: *> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
43: *> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
44: *>
45: *> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
46: *> ( L21 I ) ( 0 A22 ) ( 0 I )
47: *>
48: *> where the order of D is at most NB. The actual order is returned in
49: *> the argument KB, and is either NB or NB-1, or N if N <= NB.
50: *>
51: *> DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
52: *> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
53: *> A22 (if UPLO = 'L').
54: *> \endverbatim
55: *
56: * Arguments:
57: * ==========
58: *
59: *> \param[in] UPLO
60: *> \verbatim
61: *> UPLO is CHARACTER*1
62: *> Specifies whether the upper or lower triangular part of the
63: *> symmetric matrix A is stored:
64: *> = 'U': Upper triangular
65: *> = 'L': Lower triangular
66: *> \endverbatim
67: *>
68: *> \param[in] N
69: *> \verbatim
70: *> N is INTEGER
71: *> The order of the matrix A. N >= 0.
72: *> \endverbatim
73: *>
74: *> \param[in] NB
75: *> \verbatim
76: *> NB is INTEGER
77: *> The maximum number of columns of the matrix A that should be
78: *> factored. NB should be at least 2 to allow for 2-by-2 pivot
79: *> blocks.
80: *> \endverbatim
81: *>
82: *> \param[out] KB
83: *> \verbatim
84: *> KB is INTEGER
85: *> The number of columns of A that were actually factored.
86: *> KB is either NB-1 or NB, or N if N <= NB.
87: *> \endverbatim
88: *>
89: *> \param[in,out] A
90: *> \verbatim
91: *> A is DOUBLE PRECISION array, dimension (LDA,N)
92: *> On entry, the symmetric matrix A. If UPLO = 'U', the leading
93: *> n-by-n upper triangular part of A contains the upper
94: *> triangular part of the matrix A, and the strictly lower
95: *> triangular part of A is not referenced. If UPLO = 'L', the
96: *> leading n-by-n lower triangular part of A contains the lower
97: *> triangular part of the matrix A, and the strictly upper
98: *> triangular part of A is not referenced.
99: *> On exit, A contains details of the partial factorization.
100: *> \endverbatim
101: *>
102: *> \param[in] LDA
103: *> \verbatim
104: *> LDA is INTEGER
105: *> The leading dimension of the array A. LDA >= max(1,N).
106: *> \endverbatim
107: *>
108: *> \param[out] IPIV
109: *> \verbatim
110: *> IPIV is INTEGER array, dimension (N)
111: *> Details of the interchanges and the block structure of D.
112: *>
1.14 bertrand 113: *> If UPLO = 'U':
114: *> Only the last KB elements of IPIV are set.
115: *>
116: *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
117: *> interchanged and D(k,k) is a 1-by-1 diagonal block.
118: *>
119: *> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
120: *> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
121: *> is a 2-by-2 diagonal block.
122: *>
123: *> If UPLO = 'L':
124: *> Only the first KB elements of IPIV are set.
125: *>
126: *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
127: *> interchanged and D(k,k) is a 1-by-1 diagonal block.
128: *>
129: *> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
130: *> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
131: *> is a 2-by-2 diagonal block.
1.9 bertrand 132: *> \endverbatim
133: *>
134: *> \param[out] W
135: *> \verbatim
136: *> W is DOUBLE PRECISION array, dimension (LDW,NB)
137: *> \endverbatim
138: *>
139: *> \param[in] LDW
140: *> \verbatim
141: *> LDW is INTEGER
142: *> The leading dimension of the array W. LDW >= max(1,N).
143: *> \endverbatim
144: *>
145: *> \param[out] INFO
146: *> \verbatim
147: *> INFO is INTEGER
148: *> = 0: successful exit
149: *> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
150: *> has been completed, but the block diagonal matrix D is
151: *> exactly singular.
152: *> \endverbatim
153: *
154: * Authors:
155: * ========
156: *
1.14 bertrand 157: *> \author Univ. of Tennessee
158: *> \author Univ. of California Berkeley
159: *> \author Univ. of Colorado Denver
160: *> \author NAG Ltd.
1.9 bertrand 161: *
1.14 bertrand 162: *> \date November 2013
1.9 bertrand 163: *
164: *> \ingroup doubleSYcomputational
165: *
1.14 bertrand 166: *> \par Contributors:
167: * ==================
168: *>
169: *> \verbatim
170: *>
171: *> November 2013, Igor Kozachenko,
172: *> Computer Science Division,
173: *> University of California, Berkeley
174: *> \endverbatim
175: *
1.9 bertrand 176: * =====================================================================
1.1 bertrand 177: SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
178: *
1.14 bertrand 179: * -- LAPACK computational routine (version 3.5.0) --
1.1 bertrand 180: * -- LAPACK is a software package provided by Univ. of Tennessee, --
181: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.14 bertrand 182: * November 2013
1.1 bertrand 183: *
184: * .. Scalar Arguments ..
185: CHARACTER UPLO
186: INTEGER INFO, KB, LDA, LDW, N, NB
187: * ..
188: * .. Array Arguments ..
189: INTEGER IPIV( * )
190: DOUBLE PRECISION A( LDA, * ), W( LDW, * )
191: * ..
192: *
193: * =====================================================================
194: *
195: * .. Parameters ..
196: DOUBLE PRECISION ZERO, ONE
197: PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
198: DOUBLE PRECISION EIGHT, SEVTEN
199: PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
200: * ..
201: * .. Local Scalars ..
202: INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
203: $ KSTEP, KW
204: DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
205: $ ROWMAX, T
206: * ..
207: * .. External Functions ..
208: LOGICAL LSAME
209: INTEGER IDAMAX
210: EXTERNAL LSAME, IDAMAX
211: * ..
212: * .. External Subroutines ..
213: EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
214: * ..
215: * .. Intrinsic Functions ..
216: INTRINSIC ABS, MAX, MIN, SQRT
217: * ..
218: * .. Executable Statements ..
219: *
220: INFO = 0
221: *
222: * Initialize ALPHA for use in choosing pivot block size.
223: *
224: ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
225: *
226: IF( LSAME( UPLO, 'U' ) ) THEN
227: *
228: * Factorize the trailing columns of A using the upper triangle
229: * of A and working backwards, and compute the matrix W = U12*D
230: * for use in updating A11
231: *
232: * K is the main loop index, decreasing from N in steps of 1 or 2
233: *
234: * KW is the column of W which corresponds to column K of A
235: *
236: K = N
237: 10 CONTINUE
238: KW = NB + K - N
239: *
240: * Exit from loop
241: *
242: IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
243: $ GO TO 30
244: *
245: * Copy column K of A to column KW of W and update it
246: *
247: CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
248: IF( K.LT.N )
249: $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA,
250: $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
251: *
252: KSTEP = 1
253: *
254: * Determine rows and columns to be interchanged and whether
255: * a 1-by-1 or 2-by-2 pivot block will be used
256: *
257: ABSAKK = ABS( W( K, KW ) )
258: *
259: * IMAX is the row-index of the largest off-diagonal element in
1.14 bertrand 260: * column K, and COLMAX is its absolute value.
261: * Determine both COLMAX and IMAX.
1.1 bertrand 262: *
263: IF( K.GT.1 ) THEN
264: IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
265: COLMAX = ABS( W( IMAX, KW ) )
266: ELSE
267: COLMAX = ZERO
268: END IF
269: *
270: IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
271: *
1.14 bertrand 272: * Column K is zero or underflow: set INFO and continue
1.1 bertrand 273: *
274: IF( INFO.EQ.0 )
275: $ INFO = K
276: KP = K
277: ELSE
278: IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
279: *
280: * no interchange, use 1-by-1 pivot block
281: *
282: KP = K
283: ELSE
284: *
285: * Copy column IMAX to column KW-1 of W and update it
286: *
287: CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
288: CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
289: $ W( IMAX+1, KW-1 ), 1 )
290: IF( K.LT.N )
291: $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
292: $ LDA, W( IMAX, KW+1 ), LDW, ONE,
293: $ W( 1, KW-1 ), 1 )
294: *
295: * JMAX is the column-index of the largest off-diagonal
296: * element in row IMAX, and ROWMAX is its absolute value
297: *
298: JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
299: ROWMAX = ABS( W( JMAX, KW-1 ) )
300: IF( IMAX.GT.1 ) THEN
301: JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
302: ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
303: END IF
304: *
305: IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
306: *
307: * no interchange, use 1-by-1 pivot block
308: *
309: KP = K
310: ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
311: *
312: * interchange rows and columns K and IMAX, use 1-by-1
313: * pivot block
314: *
315: KP = IMAX
316: *
1.14 bertrand 317: * copy column KW-1 of W to column KW of W
1.1 bertrand 318: *
319: CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
320: ELSE
321: *
322: * interchange rows and columns K-1 and IMAX, use 2-by-2
323: * pivot block
324: *
325: KP = IMAX
326: KSTEP = 2
327: END IF
328: END IF
329: *
1.14 bertrand 330: * ============================================================
331: *
332: * KK is the column of A where pivoting step stopped
333: *
1.1 bertrand 334: KK = K - KSTEP + 1
1.14 bertrand 335: *
336: * KKW is the column of W which corresponds to column KK of A
337: *
1.1 bertrand 338: KKW = NB + KK - N
339: *
1.14 bertrand 340: * Interchange rows and columns KP and KK.
341: * Updated column KP is already stored in column KKW of W.
1.1 bertrand 342: *
343: IF( KP.NE.KK ) THEN
344: *
1.14 bertrand 345: * Copy non-updated column KK to column KP of submatrix A
346: * at step K. No need to copy element into column K
347: * (or K and K-1 for 2-by-2 pivot) of A, since these columns
348: * will be later overwritten.
1.1 bertrand 349: *
1.14 bertrand 350: A( KP, KP ) = A( KK, KK )
351: CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
1.1 bertrand 352: $ LDA )
1.14 bertrand 353: IF( KP.GT.1 )
354: $ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
1.1 bertrand 355: *
1.14 bertrand 356: * Interchange rows KK and KP in last K+1 to N columns of A
357: * (columns K (or K and K-1 for 2-by-2 pivot) of A will be
358: * later overwritten). Interchange rows KK and KP
359: * in last KKW to NB columns of W.
1.1 bertrand 360: *
1.14 bertrand 361: IF( K.LT.N )
362: $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
363: $ LDA )
1.1 bertrand 364: CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
365: $ LDW )
366: END IF
367: *
368: IF( KSTEP.EQ.1 ) THEN
369: *
1.14 bertrand 370: * 1-by-1 pivot block D(k): column kw of W now holds
1.1 bertrand 371: *
1.14 bertrand 372: * W(kw) = U(k)*D(k),
1.1 bertrand 373: *
374: * where U(k) is the k-th column of U
375: *
1.14 bertrand 376: * Store subdiag. elements of column U(k)
377: * and 1-by-1 block D(k) in column k of A.
378: * NOTE: Diagonal element U(k,k) is a UNIT element
379: * and not stored.
380: * A(k,k) := D(k,k) = W(k,kw)
381: * A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
1.1 bertrand 382: *
383: CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
384: R1 = ONE / A( K, K )
385: CALL DSCAL( K-1, R1, A( 1, K ), 1 )
1.14 bertrand 386: *
1.1 bertrand 387: ELSE
388: *
1.14 bertrand 389: * 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
1.1 bertrand 390: *
1.14 bertrand 391: * ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
1.1 bertrand 392: *
393: * where U(k) and U(k-1) are the k-th and (k-1)-th columns
394: * of U
395: *
1.14 bertrand 396: * Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
397: * block D(k-1:k,k-1:k) in columns k-1 and k of A.
398: * NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
399: * block and not stored.
400: * A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
401: * A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
402: * = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
403: *
1.1 bertrand 404: IF( K.GT.2 ) THEN
405: *
1.14 bertrand 406: * Compose the columns of the inverse of 2-by-2 pivot
407: * block D in the following way to reduce the number
408: * of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
409: * this inverse
410: *
411: * D**(-1) = ( d11 d21 )**(-1) =
412: * ( d21 d22 )
413: *
414: * = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
415: * ( (-d21 ) ( d11 ) )
416: *
417: * = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
418: *
419: * * ( ( d22/d21 ) ( -1 ) ) =
420: * ( ( -1 ) ( d11/d21 ) )
421: *
422: * = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
423: * ( ( -1 ) ( D22 ) )
424: *
425: * = 1/d21 * T * ( ( D11 ) ( -1 ) )
426: * ( ( -1 ) ( D22 ) )
427: *
428: * = D21 * ( ( D11 ) ( -1 ) )
429: * ( ( -1 ) ( D22 ) )
1.1 bertrand 430: *
431: D21 = W( K-1, KW )
432: D11 = W( K, KW ) / D21
433: D22 = W( K-1, KW-1 ) / D21
434: T = ONE / ( D11*D22-ONE )
435: D21 = T / D21
1.14 bertrand 436: *
437: * Update elements in columns A(k-1) and A(k) as
438: * dot products of rows of ( W(kw-1) W(kw) ) and columns
439: * of D**(-1)
440: *
1.1 bertrand 441: DO 20 J = 1, K - 2
442: A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
443: A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
444: 20 CONTINUE
445: END IF
446: *
447: * Copy D(k) to A
448: *
449: A( K-1, K-1 ) = W( K-1, KW-1 )
450: A( K-1, K ) = W( K-1, KW )
451: A( K, K ) = W( K, KW )
1.14 bertrand 452: *
1.1 bertrand 453: END IF
1.14 bertrand 454: *
1.1 bertrand 455: END IF
456: *
457: * Store details of the interchanges in IPIV
458: *
459: IF( KSTEP.EQ.1 ) THEN
460: IPIV( K ) = KP
461: ELSE
462: IPIV( K ) = -KP
463: IPIV( K-1 ) = -KP
464: END IF
465: *
466: * Decrease K and return to the start of the main loop
467: *
468: K = K - KSTEP
469: GO TO 10
470: *
471: 30 CONTINUE
472: *
473: * Update the upper triangle of A11 (= A(1:k,1:k)) as
474: *
1.8 bertrand 475: * A11 := A11 - U12*D*U12**T = A11 - U12*W**T
1.1 bertrand 476: *
477: * computing blocks of NB columns at a time
478: *
479: DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
480: JB = MIN( NB, K-J+1 )
481: *
482: * Update the upper triangle of the diagonal block
483: *
484: DO 40 JJ = J, J + JB - 1
485: CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
486: $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
487: $ A( J, JJ ), 1 )
488: 40 CONTINUE
489: *
490: * Update the rectangular superdiagonal block
491: *
492: CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE,
493: $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
494: $ A( 1, J ), LDA )
495: 50 CONTINUE
496: *
497: * Put U12 in standard form by partially undoing the interchanges
1.14 bertrand 498: * in columns k+1:n looping backwards from k+1 to n
1.1 bertrand 499: *
500: J = K + 1
501: 60 CONTINUE
1.14 bertrand 502: *
503: * Undo the interchanges (if any) of rows JJ and JP at each
504: * step J
505: *
506: * (Here, J is a diagonal index)
507: JJ = J
508: JP = IPIV( J )
509: IF( JP.LT.0 ) THEN
510: JP = -JP
511: * (Here, J is a diagonal index)
512: J = J + 1
513: END IF
514: * (NOTE: Here, J is used to determine row length. Length N-J+1
515: * of the rows to swap back doesn't include diagonal element)
1.1 bertrand 516: J = J + 1
1.14 bertrand 517: IF( JP.NE.JJ .AND. J.LE.N )
518: $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
519: IF( J.LT.N )
1.1 bertrand 520: $ GO TO 60
521: *
522: * Set KB to the number of columns factorized
523: *
524: KB = N - K
525: *
526: ELSE
527: *
528: * Factorize the leading columns of A using the lower triangle
529: * of A and working forwards, and compute the matrix W = L21*D
530: * for use in updating A22
531: *
532: * K is the main loop index, increasing from 1 in steps of 1 or 2
533: *
534: K = 1
535: 70 CONTINUE
536: *
537: * Exit from loop
538: *
539: IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
540: $ GO TO 90
541: *
542: * Copy column K of A to column K of W and update it
543: *
544: CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
545: CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
546: $ W( K, 1 ), LDW, ONE, W( K, K ), 1 )
547: *
548: KSTEP = 1
549: *
550: * Determine rows and columns to be interchanged and whether
551: * a 1-by-1 or 2-by-2 pivot block will be used
552: *
553: ABSAKK = ABS( W( K, K ) )
554: *
555: * IMAX is the row-index of the largest off-diagonal element in
1.14 bertrand 556: * column K, and COLMAX is its absolute value.
557: * Determine both COLMAX and IMAX.
1.1 bertrand 558: *
559: IF( K.LT.N ) THEN
560: IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
561: COLMAX = ABS( W( IMAX, K ) )
562: ELSE
563: COLMAX = ZERO
564: END IF
565: *
566: IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
567: *
1.14 bertrand 568: * Column K is zero or underflow: set INFO and continue
1.1 bertrand 569: *
570: IF( INFO.EQ.0 )
571: $ INFO = K
572: KP = K
573: ELSE
574: IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
575: *
576: * no interchange, use 1-by-1 pivot block
577: *
578: KP = K
579: ELSE
580: *
581: * Copy column IMAX to column K+1 of W and update it
582: *
583: CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
584: CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
585: $ 1 )
586: CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
587: $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
588: *
589: * JMAX is the column-index of the largest off-diagonal
590: * element in row IMAX, and ROWMAX is its absolute value
591: *
592: JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
593: ROWMAX = ABS( W( JMAX, K+1 ) )
594: IF( IMAX.LT.N ) THEN
595: JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
596: ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
597: END IF
598: *
599: IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
600: *
601: * no interchange, use 1-by-1 pivot block
602: *
603: KP = K
604: ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
605: *
606: * interchange rows and columns K and IMAX, use 1-by-1
607: * pivot block
608: *
609: KP = IMAX
610: *
1.14 bertrand 611: * copy column K+1 of W to column K of W
1.1 bertrand 612: *
613: CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
614: ELSE
615: *
616: * interchange rows and columns K+1 and IMAX, use 2-by-2
617: * pivot block
618: *
619: KP = IMAX
620: KSTEP = 2
621: END IF
622: END IF
623: *
1.14 bertrand 624: * ============================================================
625: *
626: * KK is the column of A where pivoting step stopped
627: *
1.1 bertrand 628: KK = K + KSTEP - 1
629: *
1.14 bertrand 630: * Interchange rows and columns KP and KK.
631: * Updated column KP is already stored in column KK of W.
1.1 bertrand 632: *
633: IF( KP.NE.KK ) THEN
634: *
1.14 bertrand 635: * Copy non-updated column KK to column KP of submatrix A
636: * at step K. No need to copy element into column K
637: * (or K and K+1 for 2-by-2 pivot) of A, since these columns
638: * will be later overwritten.
1.1 bertrand 639: *
1.14 bertrand 640: A( KP, KP ) = A( KK, KK )
641: CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
642: $ LDA )
643: IF( KP.LT.N )
644: $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
1.1 bertrand 645: *
1.14 bertrand 646: * Interchange rows KK and KP in first K-1 columns of A
647: * (columns K (or K and K+1 for 2-by-2 pivot) of A will be
648: * later overwritten). Interchange rows KK and KP
649: * in first KK columns of W.
1.1 bertrand 650: *
1.14 bertrand 651: IF( K.GT.1 )
652: $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
1.1 bertrand 653: CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
654: END IF
655: *
656: IF( KSTEP.EQ.1 ) THEN
657: *
658: * 1-by-1 pivot block D(k): column k of W now holds
659: *
1.14 bertrand 660: * W(k) = L(k)*D(k),
1.1 bertrand 661: *
662: * where L(k) is the k-th column of L
663: *
1.14 bertrand 664: * Store subdiag. elements of column L(k)
665: * and 1-by-1 block D(k) in column k of A.
666: * (NOTE: Diagonal element L(k,k) is a UNIT element
667: * and not stored)
668: * A(k,k) := D(k,k) = W(k,k)
669: * A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
1.1 bertrand 670: *
671: CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
672: IF( K.LT.N ) THEN
673: R1 = ONE / A( K, K )
674: CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
675: END IF
1.14 bertrand 676: *
1.1 bertrand 677: ELSE
678: *
679: * 2-by-2 pivot block D(k): columns k and k+1 of W now hold
680: *
681: * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
682: *
683: * where L(k) and L(k+1) are the k-th and (k+1)-th columns
684: * of L
685: *
1.14 bertrand 686: * Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
687: * block D(k:k+1,k:k+1) in columns k and k+1 of A.
688: * (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
689: * block and not stored)
690: * A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
691: * A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
692: * = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
693: *
1.1 bertrand 694: IF( K.LT.N-1 ) THEN
695: *
1.14 bertrand 696: * Compose the columns of the inverse of 2-by-2 pivot
697: * block D in the following way to reduce the number
698: * of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
699: * this inverse
700: *
701: * D**(-1) = ( d11 d21 )**(-1) =
702: * ( d21 d22 )
703: *
704: * = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
705: * ( (-d21 ) ( d11 ) )
706: *
707: * = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
708: *
709: * * ( ( d22/d21 ) ( -1 ) ) =
710: * ( ( -1 ) ( d11/d21 ) )
711: *
712: * = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
713: * ( ( -1 ) ( D22 ) )
714: *
715: * = 1/d21 * T * ( ( D11 ) ( -1 ) )
716: * ( ( -1 ) ( D22 ) )
717: *
718: * = D21 * ( ( D11 ) ( -1 ) )
719: * ( ( -1 ) ( D22 ) )
1.1 bertrand 720: *
721: D21 = W( K+1, K )
722: D11 = W( K+1, K+1 ) / D21
723: D22 = W( K, K ) / D21
724: T = ONE / ( D11*D22-ONE )
725: D21 = T / D21
1.14 bertrand 726: *
727: * Update elements in columns A(k) and A(k+1) as
728: * dot products of rows of ( W(k) W(k+1) ) and columns
729: * of D**(-1)
730: *
1.1 bertrand 731: DO 80 J = K + 2, N
732: A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
733: A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
734: 80 CONTINUE
735: END IF
736: *
737: * Copy D(k) to A
738: *
739: A( K, K ) = W( K, K )
740: A( K+1, K ) = W( K+1, K )
741: A( K+1, K+1 ) = W( K+1, K+1 )
1.14 bertrand 742: *
1.1 bertrand 743: END IF
1.14 bertrand 744: *
1.1 bertrand 745: END IF
746: *
747: * Store details of the interchanges in IPIV
748: *
749: IF( KSTEP.EQ.1 ) THEN
750: IPIV( K ) = KP
751: ELSE
752: IPIV( K ) = -KP
753: IPIV( K+1 ) = -KP
754: END IF
755: *
756: * Increase K and return to the start of the main loop
757: *
758: K = K + KSTEP
759: GO TO 70
760: *
761: 90 CONTINUE
762: *
763: * Update the lower triangle of A22 (= A(k:n,k:n)) as
764: *
1.8 bertrand 765: * A22 := A22 - L21*D*L21**T = A22 - L21*W**T
1.1 bertrand 766: *
767: * computing blocks of NB columns at a time
768: *
769: DO 110 J = K, N, NB
770: JB = MIN( NB, N-J+1 )
771: *
772: * Update the lower triangle of the diagonal block
773: *
774: DO 100 JJ = J, J + JB - 1
775: CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
776: $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
777: $ A( JJ, JJ ), 1 )
778: 100 CONTINUE
779: *
780: * Update the rectangular subdiagonal block
781: *
782: IF( J+JB.LE.N )
783: $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
784: $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
785: $ ONE, A( J+JB, J ), LDA )
786: 110 CONTINUE
787: *
788: * Put L21 in standard form by partially undoing the interchanges
1.14 bertrand 789: * of rows in columns 1:k-1 looping backwards from k-1 to 1
1.1 bertrand 790: *
791: J = K - 1
792: 120 CONTINUE
1.14 bertrand 793: *
794: * Undo the interchanges (if any) of rows JJ and JP at each
795: * step J
796: *
797: * (Here, J is a diagonal index)
798: JJ = J
799: JP = IPIV( J )
800: IF( JP.LT.0 ) THEN
801: JP = -JP
802: * (Here, J is a diagonal index)
803: J = J - 1
804: END IF
805: * (NOTE: Here, J is used to determine row length. Length J
806: * of the rows to swap back doesn't include diagonal element)
1.1 bertrand 807: J = J - 1
1.14 bertrand 808: IF( JP.NE.JJ .AND. J.GE.1 )
809: $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
810: IF( J.GT.1 )
1.1 bertrand 811: $ GO TO 120
812: *
813: * Set KB to the number of columns factorized
814: *
815: KB = K - 1
816: *
817: END IF
818: RETURN
819: *
820: * End of DLASYF
821: *
822: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlasyf.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack