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 )
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
406 subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
complex function cdotc(N, CX, INCX, CY, INCY)
CDOTC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP