110 SUBROUTINE chptri( UPLO, N, AP, IPIV, WORK, INFO )
123 COMPLEX ap( * ), work( * )
131 parameter( one = 1.0e+0, cone = ( 1.0e+0, 0.0e+0 ),
132 $ zero = ( 0.0e+0, 0.0e+0 ) )
136 INTEGER j, k, kc, kcnext, kp, kpc, kstep, kx, npp
149 INTRINSIC abs, conjg, real
156 upper =
lsame( uplo,
'U' )
157 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
159 ELSE IF( n.LT.0 )
THEN
163 CALL
xerbla(
'CHPTRI', -info )
179 DO 10 info = n, 1, -1
180 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
190 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
192 kp = kp + n - info + 1
214 IF( ipiv( k ).GT.0 )
THEN
220 ap( kc+k-1 ) = one /
REAL( AP( KC+K-1 ) )
225 CALL
ccopy( k-1, ap( kc ), 1, work, 1 )
226 CALL
chpmv( uplo, k-1, -cone, ap, work, 1, zero,
228 ap( kc+k-1 ) = ap( kc+k-1 ) -
229 $
REAL( CDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
238 t = abs( ap( kcnext+k-1 ) )
239 ak =
REAL( AP( KC+K-1 ) ) / t
240 akp1 =
REAL( AP( KCNEXT+K ) ) / t
241 akkp1 = ap( kcnext+k-1 ) / t
242 d = t*( ak*akp1-one )
243 ap( kc+k-1 ) = akp1 / d
244 ap( kcnext+k ) = ak / d
245 ap( kcnext+k-1 ) = -akkp1 / d
250 CALL
ccopy( k-1, ap( kc ), 1, work, 1 )
251 CALL
chpmv( uplo, k-1, -cone, ap, work, 1, zero,
253 ap( kc+k-1 ) = ap( kc+k-1 ) -
254 $
REAL( CDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
255 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
256 $
cdotc( k-1, ap( kc ), 1, ap( kcnext ),
258 CALL
ccopy( k-1, ap( kcnext ), 1, work, 1 )
259 CALL
chpmv( uplo, k-1, -cone, ap, work, 1, zero,
261 ap( kcnext+k ) = ap( kcnext+k ) -
262 $
REAL( CDOTC( K-1, WORK, 1, AP( KCNEXT ),
$ 1 ) )
265 kcnext = kcnext + k + 1
268 kp = abs( ipiv( k ) )
274 kpc = ( kp-1 )*kp / 2 + 1
275 CALL
cswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
277 DO 40
j = kp + 1, k - 1
279 temp = conjg( ap( kc+
j-1 ) )
280 ap( kc+
j-1 ) = conjg( ap( kx ) )
283 ap( kc+kp-1 ) = conjg( ap( kc+kp-1 ) )
285 ap( kc+k-1 ) = ap( kpc+kp-1 )
286 ap( kpc+kp-1 ) = temp
287 IF( kstep.EQ.2 )
THEN
288 temp = ap( kc+k+k-1 )
289 ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
290 ap( kc+k+kp-1 ) = temp
316 kcnext = kc - ( n-k+2 )
317 IF( ipiv( k ).GT.0 )
THEN
323 ap( kc ) = one /
REAL( AP( KC ) )
328 CALL
ccopy( n-k, ap( kc+1 ), 1, work, 1 )
329 CALL
chpmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1,
330 $ zero, ap( kc+1 ), 1 )
331 ap( kc ) = ap( kc ) -
REAL( CDOTC( N-K, WORK, 1,
$ AP( KC+1 ), 1 ) )
340 t = abs( ap( kcnext+1 ) )
341 ak =
REAL( AP( KCNEXT ) ) / t
342 akp1 =
REAL( AP( KC ) ) / t
343 akkp1 = ap( kcnext+1 ) / t
344 d = t*( ak*akp1-one )
345 ap( kcnext ) = akp1 / d
347 ap( kcnext+1 ) = -akkp1 / d
352 CALL
ccopy( n-k, ap( kc+1 ), 1, work, 1 )
353 CALL
chpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,
354 $ 1, zero, ap( kc+1 ), 1 )
355 ap( kc ) = ap( kc ) -
REAL( CDOTC( N-K, WORK, 1,
$ AP( KC+1 ), 1 ) )
356 ap( kcnext+1 ) = ap( kcnext+1 ) -
357 $
cdotc( n-k, ap( kc+1 ), 1,
358 $ ap( kcnext+2 ), 1 )
359 CALL
ccopy( n-k, ap( kcnext+2 ), 1, work, 1 )
360 CALL
chpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,
361 $ 1, zero, ap( kcnext+2 ), 1 )
362 ap( kcnext ) = ap( kcnext ) -
363 $
REAL( CDOTC( N-K, WORK, 1, AP( KCNEXT+2 ),
$ 1 ) )
366 kcnext = kcnext - ( n-k+3 )
369 kp = abs( ipiv( k ) )
375 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
377 $ CALL
cswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
379 DO 70
j = k + 1, kp - 1
381 temp = conjg( ap( kc+
j-k ) )
382 ap( kc+
j-k ) = conjg( ap( kx ) )
385 ap( kc+kp-k ) = conjg( ap( kc+kp-k ) )
389 IF( kstep.EQ.2 )
THEN
390 temp = ap( kc-n+k-1 )
391 ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
392 ap( kc-n+kp-1 ) = temp
407 LOGICAL function lsame(CA, CB)
LSAME
subroutine chptri(UPLO, N, AP, IPIV, WORK, INFO)
CHPTRI
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
COMPLEX function cdotc(N, CX, INCX, CY, INCY)
CDOTC
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY