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