00001 SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO )
00002
00003
00004
00005
00006
00007
00008
00009 CHARACTER UPLO
00010 INTEGER INFO, N
00011
00012
00013 INTEGER IPIV( * )
00014 COMPLEX AP( * ), WORK( * )
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041
00042
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063 REAL ONE
00064 COMPLEX CONE, ZERO
00065 PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ),
00066 $ ZERO = ( 0.0E+0, 0.0E+0 ) )
00067
00068
00069 LOGICAL UPPER
00070 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
00071 REAL AK, AKP1, D, T
00072 COMPLEX AKKP1, TEMP
00073
00074
00075 LOGICAL LSAME
00076 COMPLEX CDOTC
00077 EXTERNAL LSAME, CDOTC
00078
00079
00080 EXTERNAL CCOPY, CHPMV, CSWAP, XERBLA
00081
00082
00083 INTRINSIC ABS, CONJG, REAL
00084
00085
00086
00087
00088
00089 INFO = 0
00090 UPPER = LSAME( UPLO, 'U' )
00091 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
00092 INFO = -1
00093 ELSE IF( N.LT.0 ) THEN
00094 INFO = -2
00095 END IF
00096 IF( INFO.NE.0 ) THEN
00097 CALL XERBLA( 'CHPTRI', -INFO )
00098 RETURN
00099 END IF
00100
00101
00102
00103 IF( N.EQ.0 )
00104 $ RETURN
00105
00106
00107
00108 IF( UPPER ) THEN
00109
00110
00111
00112 KP = N*( N+1 ) / 2
00113 DO 10 INFO = N, 1, -1
00114 IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
00115 $ RETURN
00116 KP = KP - INFO
00117 10 CONTINUE
00118 ELSE
00119
00120
00121
00122 KP = 1
00123 DO 20 INFO = 1, N
00124 IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
00125 $ RETURN
00126 KP = KP + N - INFO + 1
00127 20 CONTINUE
00128 END IF
00129 INFO = 0
00130
00131 IF( UPPER ) THEN
00132
00133
00134
00135
00136
00137
00138 K = 1
00139 KC = 1
00140 30 CONTINUE
00141
00142
00143
00144 IF( K.GT.N )
00145 $ GO TO 50
00146
00147 KCNEXT = KC + K
00148 IF( IPIV( K ).GT.0 ) THEN
00149
00150
00151
00152
00153
00154 AP( KC+K-1 ) = ONE / REAL( AP( KC+K-1 ) )
00155
00156
00157
00158 IF( K.GT.1 ) THEN
00159 CALL CCOPY( K-1, AP( KC ), 1, WORK, 1 )
00160 CALL CHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
00161 $ AP( KC ), 1 )
00162 AP( KC+K-1 ) = AP( KC+K-1 ) -
00163 $ REAL( CDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
00164 END IF
00165 KSTEP = 1
00166 ELSE
00167
00168
00169
00170
00171
00172 T = ABS( AP( KCNEXT+K-1 ) )
00173 AK = REAL( AP( KC+K-1 ) ) / T
00174 AKP1 = REAL( AP( KCNEXT+K ) ) / T
00175 AKKP1 = AP( KCNEXT+K-1 ) / T
00176 D = T*( AK*AKP1-ONE )
00177 AP( KC+K-1 ) = AKP1 / D
00178 AP( KCNEXT+K ) = AK / D
00179 AP( KCNEXT+K-1 ) = -AKKP1 / D
00180
00181
00182
00183 IF( K.GT.1 ) THEN
00184 CALL CCOPY( K-1, AP( KC ), 1, WORK, 1 )
00185 CALL CHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
00186 $ AP( KC ), 1 )
00187 AP( KC+K-1 ) = AP( KC+K-1 ) -
00188 $ REAL( CDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
00189 AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
00190 $ CDOTC( K-1, AP( KC ), 1, AP( KCNEXT ),
00191 $ 1 )
00192 CALL CCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
00193 CALL CHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
00194 $ AP( KCNEXT ), 1 )
00195 AP( KCNEXT+K ) = AP( KCNEXT+K ) -
00196 $ REAL( CDOTC( K-1, WORK, 1, AP( KCNEXT ),
$ 1 ) )
00197 END IF
00198 KSTEP = 2
00199 KCNEXT = KCNEXT + K + 1
00200 END IF
00201
00202 KP = ABS( IPIV( K ) )
00203 IF( KP.NE.K ) THEN
00204
00205
00206
00207
00208 KPC = ( KP-1 )*KP / 2 + 1
00209 CALL CSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
00210 KX = KPC + KP - 1
00211 DO 40 J = KP + 1, K - 1
00212 KX = KX + J - 1
00213 TEMP = CONJG( AP( KC+J-1 ) )
00214 AP( KC+J-1 ) = CONJG( AP( KX ) )
00215 AP( KX ) = TEMP
00216 40 CONTINUE
00217 AP( KC+KP-1 ) = CONJG( AP( KC+KP-1 ) )
00218 TEMP = AP( KC+K-1 )
00219 AP( KC+K-1 ) = AP( KPC+KP-1 )
00220 AP( KPC+KP-1 ) = TEMP
00221 IF( KSTEP.EQ.2 ) THEN
00222 TEMP = AP( KC+K+K-1 )
00223 AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
00224 AP( KC+K+KP-1 ) = TEMP
00225 END IF
00226 END IF
00227
00228 K = K + KSTEP
00229 KC = KCNEXT
00230 GO TO 30
00231 50 CONTINUE
00232
00233 ELSE
00234
00235
00236
00237
00238
00239
00240 NPP = N*( N+1 ) / 2
00241 K = N
00242 KC = NPP
00243 60 CONTINUE
00244
00245
00246
00247 IF( K.LT.1 )
00248 $ GO TO 80
00249
00250 KCNEXT = KC - ( N-K+2 )
00251 IF( IPIV( K ).GT.0 ) THEN
00252
00253
00254
00255
00256
00257 AP( KC ) = ONE / REAL( AP( KC ) )
00258
00259
00260
00261 IF( K.LT.N ) THEN
00262 CALL CCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
00263 CALL CHPMV( UPLO, N-K, -CONE, AP( KC+N-K+1 ), WORK, 1,
00264 $ ZERO, AP( KC+1 ), 1 )
00265 AP( KC ) = AP( KC ) - REAL( CDOTC( N-K, WORK, 1,
$ AP( KC+1 ), 1 ) )
00266 END IF
00267 KSTEP = 1
00268 ELSE
00269
00270
00271
00272
00273
00274 T = ABS( AP( KCNEXT+1 ) )
00275 AK = REAL( AP( KCNEXT ) ) / T
00276 AKP1 = REAL( AP( KC ) ) / T
00277 AKKP1 = AP( KCNEXT+1 ) / T
00278 D = T*( AK*AKP1-ONE )
00279 AP( KCNEXT ) = AKP1 / D
00280 AP( KC ) = AK / D
00281 AP( KCNEXT+1 ) = -AKKP1 / D
00282
00283
00284
00285 IF( K.LT.N ) THEN
00286 CALL CCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
00287 CALL CHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ), WORK,
00288 $ 1, ZERO, AP( KC+1 ), 1 )
00289 AP( KC ) = AP( KC ) - REAL( CDOTC( N-K, WORK, 1,
$ AP( KC+1 ), 1 ) )
00290 AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
00291 $ CDOTC( N-K, AP( KC+1 ), 1,
00292 $ AP( KCNEXT+2 ), 1 )
00293 CALL CCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
00294 CALL CHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ), WORK,
00295 $ 1, ZERO, AP( KCNEXT+2 ), 1 )
00296 AP( KCNEXT ) = AP( KCNEXT ) -
00297 $ REAL( CDOTC( N-K, WORK, 1, AP( KCNEXT+2 ),
$ 1 ) )
00298 END IF
00299 KSTEP = 2
00300 KCNEXT = KCNEXT - ( N-K+3 )
00301 END IF
00302
00303 KP = ABS( IPIV( K ) )
00304 IF( KP.NE.K ) THEN
00305
00306
00307
00308
00309 KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
00310 IF( KP.LT.N )
00311 $ CALL CSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
00312 KX = KC + KP - K
00313 DO 70 J = K + 1, KP - 1
00314 KX = KX + N - J + 1
00315 TEMP = CONJG( AP( KC+J-K ) )
00316 AP( KC+J-K ) = CONJG( AP( KX ) )
00317 AP( KX ) = TEMP
00318 70 CONTINUE
00319 AP( KC+KP-K ) = CONJG( AP( KC+KP-K ) )
00320 TEMP = AP( KC )
00321 AP( KC ) = AP( KPC )
00322 AP( KPC ) = TEMP
00323 IF( KSTEP.EQ.2 ) THEN
00324 TEMP = AP( KC-N+K-1 )
00325 AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
00326 AP( KC-N+KP-1 ) = TEMP
00327 END IF
00328 END IF
00329
00330 K = K - KSTEP
00331 KC = KCNEXT
00332 GO TO 60
00333 80 CONTINUE
00334 END IF
00335
00336 RETURN
00337
00338
00339
00340 END
00341