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