```001:       SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
002: *
003: *  -- LAPACK PROTOTYPE routine (version 3.2) --
004: *     Craig Lucas, University of Manchester / NAG Ltd.
005: *     October, 2008
006: *
007: *     .. Scalar Arguments ..
008:       REAL               TOL
009:       INTEGER            INFO, LDA, N, RANK
010:       CHARACTER          UPLO
011: *     ..
012: *     .. Array Arguments ..
013:       REAL               A( LDA, * ), WORK( 2*N )
014:       INTEGER            PIV( N )
015: *     ..
016: *
017: *  Purpose
018: *  =======
019: *
020: *  SPSTF2 computes the Cholesky factorization with complete
021: *  pivoting of a real symmetric positive semidefinite matrix A.
022: *
023: *  The factorization has the form
024: *     P' * A * P = U' * U ,  if UPLO = 'U',
025: *     P' * A * P = L  * L',  if UPLO = 'L',
026: *  where U is an upper triangular matrix and L is lower triangular, and
027: *  P is stored as vector PIV.
028: *
029: *  This algorithm does not attempt to check that A is positive
030: *  semidefinite. This version of the algorithm calls level 2 BLAS.
031: *
032: *  Arguments
033: *  =========
034: *
035: *  UPLO    (input) CHARACTER*1
036: *          Specifies whether the upper or lower triangular part of the
037: *          symmetric matrix A is stored.
038: *          = 'U':  Upper triangular
039: *          = 'L':  Lower triangular
040: *
041: *  N       (input) INTEGER
042: *          The order of the matrix A.  N >= 0.
043: *
044: *  A       (input/output) REAL array, dimension (LDA,N)
045: *          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
046: *          n by n upper triangular part of A contains the upper
047: *          triangular part of the matrix A, and the strictly lower
048: *          triangular part of A is not referenced.  If UPLO = 'L', the
049: *          leading n by n lower triangular part of A contains the lower
050: *          triangular part of the matrix A, and the strictly upper
051: *          triangular part of A is not referenced.
052: *
053: *          On exit, if INFO = 0, the factor U or L from the Cholesky
054: *          factorization as above.
055: *
056: *  PIV     (output) INTEGER array, dimension (N)
057: *          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.
058: *
059: *  RANK    (output) INTEGER
060: *          The rank of A given by the number of steps the algorithm
061: *          completed.
062: *
063: *  TOL     (input) REAL
064: *          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )
065: *          will be used. The algorithm terminates at the (K-1)st step
066: *          if the pivot <= TOL.
067: *
068: *  LDA     (input) INTEGER
069: *          The leading dimension of the array A.  LDA >= max(1,N).
070: *
071: *  WORK    REAL array, dimension (2*N)
072: *          Work space.
073: *
074: *  INFO    (output) INTEGER
075: *          < 0: If INFO = -K, the K-th argument had an illegal value,
076: *          = 0: algorithm completed successfully, and
077: *          > 0: the matrix A is either rank deficient with computed rank
078: *               as returned in RANK, or is indefinite.  See Section 7 of
079: *               LAPACK Working Note #161 for further information.
080: *
081: *  =====================================================================
082: *
083: *     .. Parameters ..
084:       REAL               ONE, ZERO
085:       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
086: *     ..
087: *     .. Local Scalars ..
088:       REAL               AJJ, SSTOP, STEMP
089:       INTEGER            I, ITEMP, J, PVT
090:       LOGICAL            UPPER
091: *     ..
092: *     .. External Functions ..
093:       REAL               SLAMCH
094:       LOGICAL            LSAME, SISNAN
095:       EXTERNAL           SLAMCH, LSAME, SISNAN
096: *     ..
097: *     .. External Subroutines ..
098:       EXTERNAL           SGEMV, SSCAL, SSWAP, XERBLA
099: *     ..
100: *     .. Intrinsic Functions ..
101:       INTRINSIC          MAX, SQRT, MAXLOC
102: *     ..
103: *     .. Executable Statements ..
104: *
105: *     Test the input parameters
106: *
107:       INFO = 0
108:       UPPER = LSAME( UPLO, 'U' )
109:       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
110:          INFO = -1
111:       ELSE IF( N.LT.0 ) THEN
112:          INFO = -2
113:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
114:          INFO = -4
115:       END IF
116:       IF( INFO.NE.0 ) THEN
117:          CALL XERBLA( 'SPSTF2', -INFO )
118:          RETURN
119:       END IF
120: *
121: *     Quick return if possible
122: *
123:       IF( N.EQ.0 )
124:      \$   RETURN
125: *
126: *     Initialize PIV
127: *
128:       DO 100 I = 1, N
129:          PIV( I ) = I
130:   100 CONTINUE
131: *
132: *     Compute stopping value
133: *
134:       PVT = 1
135:       AJJ = A( PVT, PVT )
136:       DO I = 2, N
137:          IF( A( I, I ).GT.AJJ ) THEN
138:             PVT = I
139:             AJJ = A( PVT, PVT )
140:          END IF
141:       END DO
142:       IF( AJJ.EQ.ZERO.OR.SISNAN( AJJ ) ) THEN
143:          RANK = 0
144:          INFO = 1
145:          GO TO 170
146:       END IF
147: *
148: *     Compute stopping value if not supplied
149: *
150:       IF( TOL.LT.ZERO ) THEN
151:          SSTOP = N * SLAMCH( 'Epsilon' ) * AJJ
152:       ELSE
153:          SSTOP = TOL
154:       END IF
155: *
156: *     Set first half of WORK to zero, holds dot products
157: *
158:       DO 110 I = 1, N
159:          WORK( I ) = 0
160:   110 CONTINUE
161: *
162:       IF( UPPER ) THEN
163: *
164: *        Compute the Cholesky factorization P' * A * P = U' * U
165: *
166:          DO 130 J = 1, N
167: *
168: *        Find pivot, test for exit, else swap rows and columns
169: *        Update dot products, compute possible pivots which are
170: *        stored in the second half of WORK
171: *
172:             DO 120 I = J, N
173: *
174:                IF( J.GT.1 ) THEN
175:                   WORK( I ) = WORK( I ) + A( J-1, I )**2
176:                END IF
177:                WORK( N+I ) = A( I, I ) - WORK( I )
178: *
179:   120       CONTINUE
180: *
181:             IF( J.GT.1 ) THEN
182:                ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 )
183:                PVT = ITEMP + J - 1
184:                AJJ = WORK( N+PVT )
185:                IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN
186:                   A( J, J ) = AJJ
187:                   GO TO 160
188:                END IF
189:             END IF
190: *
191:             IF( J.NE.PVT ) THEN
192: *
193: *              Pivot OK, so can now swap pivot rows and columns
194: *
195:                A( PVT, PVT ) = A( J, J )
196:                CALL SSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 )
197:                IF( PVT.LT.N )
198:      \$            CALL SSWAP( N-PVT, A( J, PVT+1 ), LDA,
199:      \$                        A( PVT, PVT+1 ), LDA )
200:                CALL SSWAP( PVT-J-1, A( J, J+1 ), LDA, A( J+1, PVT ), 1 )
201: *
202: *              Swap dot products and PIV
203: *
204:                STEMP = WORK( J )
205:                WORK( J ) = WORK( PVT )
206:                WORK( PVT ) = STEMP
207:                ITEMP = PIV( PVT )
208:                PIV( PVT ) = PIV( J )
209:                PIV( J ) = ITEMP
210:             END IF
211: *
212:             AJJ = SQRT( AJJ )
213:             A( J, J ) = AJJ
214: *
215: *           Compute elements J+1:N of row J
216: *
217:             IF( J.LT.N ) THEN
218:                CALL SGEMV( 'Trans', J-1, N-J, -ONE, A( 1, J+1 ), LDA,
219:      \$                     A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
220:                CALL SSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
221:             END IF
222: *
223:   130    CONTINUE
224: *
225:       ELSE
226: *
227: *        Compute the Cholesky factorization P' * A * P = L * L'
228: *
229:          DO 150 J = 1, N
230: *
231: *        Find pivot, test for exit, else swap rows and columns
232: *        Update dot products, compute possible pivots which are
233: *        stored in the second half of WORK
234: *
235:             DO 140 I = J, N
236: *
237:                IF( J.GT.1 ) THEN
238:                   WORK( I ) = WORK( I ) + A( I, J-1 )**2
239:                END IF
240:                WORK( N+I ) = A( I, I ) - WORK( I )
241: *
242:   140       CONTINUE
243: *
244:             IF( J.GT.1 ) THEN
245:                ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 )
246:                PVT = ITEMP + J - 1
247:                AJJ = WORK( N+PVT )
248:                IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN
249:                   A( J, J ) = AJJ
250:                   GO TO 160
251:                END IF
252:             END IF
253: *
254:             IF( J.NE.PVT ) THEN
255: *
256: *              Pivot OK, so can now swap pivot rows and columns
257: *
258:                A( PVT, PVT ) = A( J, J )
259:                CALL SSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA )
260:                IF( PVT.LT.N )
261:      \$            CALL SSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1, PVT ),
262:      \$                        1 )
263:                CALL SSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), LDA )
264: *
265: *              Swap dot products and PIV
266: *
267:                STEMP = WORK( J )
268:                WORK( J ) = WORK( PVT )
269:                WORK( PVT ) = STEMP
270:                ITEMP = PIV( PVT )
271:                PIV( PVT ) = PIV( J )
272:                PIV( J ) = ITEMP
273:             END IF
274: *
275:             AJJ = SQRT( AJJ )
276:             A( J, J ) = AJJ
277: *
278: *           Compute elements J+1:N of column J
279: *
280:             IF( J.LT.N ) THEN
281:                CALL SGEMV( 'No Trans', N-J, J-1, -ONE, A( J+1, 1 ), LDA,
282:      \$                     A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
283:                CALL SSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
284:             END IF
285: *
286:   150    CONTINUE
287: *
288:       END IF
289: *
290: *     Ran to completion, A has full rank
291: *
292:       RANK = N
293: *
294:       GO TO 170
295:   160 CONTINUE
296: *
297: *     Rank is number of steps completed.  Set INFO = 1 to signal
298: *     that the factorization cannot be used to solve a system.
299: *
300:       RANK = J - 1
301:       INFO = 1
302: *
303:   170 CONTINUE
304:       RETURN
305: *
306: *     End of SPSTF2
307: *
308:       END
309: ```