001:       REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV,
002:      $                            WORK )
003: *
004: *     -- LAPACK routine (version 3.2)                                 --
005: *     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
006: *     -- Jason Riedy of Univ. of California Berkeley.                 --
007: *     -- November 2008                                                --
008: *
009: *     -- LAPACK is a software package provided by Univ. of Tennessee, --
010: *     -- Univ. of California Berkeley and NAG Ltd.                    --
011: *
012:       IMPLICIT NONE
013: *     ..
014: *     .. Scalar Arguments ..
015:       CHARACTER*1        UPLO
016:       INTEGER            N, INFO, LDA, LDAF
017: *     ..
018: *     .. Array Arguments ..
019:       INTEGER            IPIV( * )
020:       REAL               A( LDA, * ), AF( LDAF, * ), WORK( * )
021: *     ..
022: *     .. Local Scalars ..
023:       INTEGER            NCOLS, I, J, K, KP
024:       REAL               AMAX, UMAX, RPVGRW, TMP
025:       LOGICAL            UPPER
026: *     ..
027: *     .. Intrinsic Functions ..
028:       INTRINSIC          ABS, MAX, MIN
029: *     ..
030: *     .. External Functions ..
031:       EXTERNAL           LSAME, SLASET
032:       LOGICAL            LSAME
033: *     ..
034: *     .. Executable Statements ..
035: *
036:       UPPER = LSAME( 'Upper', UPLO )
037:       IF ( INFO.EQ.0 ) THEN
038:          IF ( UPPER ) THEN
039:             NCOLS = 1
040:          ELSE
041:             NCOLS = N
042:          END IF
043:       ELSE
044:          NCOLS = INFO
045:       END IF
046: 
047:       RPVGRW = 1.0
048:       DO I = 1, 2*N
049:          WORK( I ) = 0.0
050:       END DO
051: *
052: *     Find the max magnitude entry of each column of A.  Compute the max
053: *     for all N columns so we can apply the pivot permutation while
054: *     looping below.  Assume a full factorization is the common case.
055: *
056:       IF ( UPPER ) THEN
057:          DO J = 1, N
058:             DO I = 1, J
059:                WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) )
060:                WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) )
061:             END DO
062:          END DO
063:       ELSE
064:          DO J = 1, N
065:             DO I = J, N
066:                WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) )
067:                WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) )
068:             END DO
069:          END DO
070:       END IF
071: *
072: *     Now find the max magnitude entry of each column of U or L.  Also
073: *     permute the magnitudes of A above so they're in the same order as
074: *     the factor.
075: *
076: *     The iteration orders and permutations were copied from ssytrs.
077: *     Calls to SSWAP would be severe overkill.
078: *
079:       IF ( UPPER ) THEN
080:          K = N
081:          DO WHILE ( K .LT. NCOLS .AND. K.GT.0 )
082:             IF ( IPIV( K ).GT.0 ) THEN
083: !              1x1 pivot
084:                KP = IPIV( K )
085:                IF ( KP .NE. K ) THEN
086:                   TMP = WORK( N+K )
087:                   WORK( N+K ) = WORK( N+KP )
088:                   WORK( N+KP ) = TMP
089:                END IF
090:                DO I = 1, K
091:                   WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) )
092:                END DO
093:                K = K - 1
094:             ELSE
095: !              2x2 pivot
096:                KP = -IPIV( K )
097:                TMP = WORK( N+K-1 )
098:                WORK( N+K-1 ) = WORK( N+KP )
099:                WORK( N+KP ) = TMP
100:                DO I = 1, K-1
101:                   WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) )
102:                   WORK( K-1 ) = MAX( ABS( AF( I, K-1 ) ), WORK( K-1 ) )
103:                END DO
104:                WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) )
105:                K = K - 2
106:             END IF
107:          END DO
108:          K = NCOLS
109:          DO WHILE ( K .LE. N )
110:             IF ( IPIV( K ).GT.0 ) THEN
111:                KP = IPIV( K )
112:                IF ( KP .NE. K ) THEN
113:                   TMP = WORK( N+K )
114:                   WORK( N+K ) = WORK( N+KP )
115:                   WORK( N+KP ) = TMP
116:                END IF
117:                K = K + 1
118:             ELSE
119:                KP = -IPIV( K )
120:                TMP = WORK( N+K )
121:                WORK( N+K ) = WORK( N+KP )
122:                WORK( N+KP ) = TMP
123:                K = K + 2
124:             END IF
125:          END DO
126:       ELSE
127:          K = 1
128:          DO WHILE ( K .LE. NCOLS )
129:             IF ( IPIV( K ).GT.0 ) THEN
130: !              1x1 pivot
131:                KP = IPIV( K )
132:                IF ( KP .NE. K ) THEN
133:                   TMP = WORK( N+K )
134:                   WORK( N+K ) = WORK( N+KP )
135:                   WORK( N+KP ) = TMP
136:                END IF
137:                DO I = K, N
138:                   WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) )
139:                END DO
140:                K = K + 1
141:             ELSE
142: !              2x2 pivot
143:                KP = -IPIV( K )
144:                TMP = WORK( N+K+1 )
145:                WORK( N+K+1 ) = WORK( N+KP )
146:                WORK( N+KP ) = TMP
147:                DO I = K+1, N
148:                   WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) )
149:                   WORK( K+1 ) = MAX( ABS( AF(I, K+1 ) ), WORK( K+1 ) )
150:                END DO
151:                WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) )
152:                K = K + 2
153:             END IF
154:          END DO
155:          K = NCOLS
156:          DO WHILE ( K .GE. 1 )
157:             IF ( IPIV( K ).GT.0 ) THEN
158:                KP = IPIV( K )
159:                IF ( KP .NE. K ) THEN
160:                   TMP = WORK( N+K )
161:                   WORK( N+K ) = WORK( N+KP )
162:                   WORK( N+KP ) = TMP
163:                END IF
164:                K = K - 1
165:             ELSE
166:                KP = -IPIV( K )
167:                TMP = WORK( N+K )
168:                WORK( N+K ) = WORK( N+KP )
169:                WORK( N+KP ) = TMP
170:                K = K - 2
171:             ENDIF
172:          END DO
173:       END IF
174: *
175: *     Compute the *inverse* of the max element growth factor.  Dividing
176: *     by zero would imply the largest entry of the factor's column is
177: *     zero.  Than can happen when either the column of A is zero or
178: *     massive pivots made the factor underflow to zero.  Neither counts
179: *     as growth in itself, so simply ignore terms with zero
180: *     denominators.
181: *
182:       IF ( UPPER ) THEN
183:          DO I = NCOLS, N
184:             UMAX = WORK( I )
185:             AMAX = WORK( N+I )
186:             IF ( UMAX /= 0.0 ) THEN
187:                RPVGRW = MIN( AMAX / UMAX, RPVGRW )
188:             END IF
189:          END DO
190:       ELSE
191:          DO I = 1, NCOLS
192:             UMAX = WORK( I )
193:             AMAX = WORK( N+I )
194:             IF ( UMAX /= 0.0 ) THEN
195:                RPVGRW = MIN( AMAX / UMAX, RPVGRW )
196:             END IF
197:          END DO
198:       END IF
199: 
200:       SLA_SYRPVGRW = RPVGRW
201:       END FUNCTION
202: