110 SUBROUTINE zsptri( UPLO, N, AP, IPIV, WORK, INFO )
123 COMPLEX*16 AP( * ), WORK( * )
130 parameter ( one = ( 1.0d+0, 0.0d+0 ),
131 $ zero = ( 0.0d+0, 0.0d+0 ) )
135 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
136 COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
141 EXTERNAL lsame, zdotu
154 upper = lsame( uplo,
'U' )
155 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
157 ELSE IF( n.LT.0 )
THEN
161 CALL xerbla(
'ZSPTRI', -info )
177 DO 10 info = n, 1, -1
178 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
188 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
190 kp = kp + n - info + 1
212 IF( ipiv( k ).GT.0 )
THEN
218 ap( kc+k-1 ) = one / ap( kc+k-1 )
223 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
224 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
226 ap( kc+k-1 ) = ap( kc+k-1 ) -
227 $ zdotu( k-1, work, 1, ap( kc ), 1 )
237 ak = ap( kc+k-1 ) / t
238 akp1 = ap( kcnext+k ) / t
239 akkp1 = ap( kcnext+k-1 ) / t
240 d = t*( ak*akp1-one )
241 ap( kc+k-1 ) = akp1 / d
242 ap( kcnext+k ) = ak / d
243 ap( kcnext+k-1 ) = -akkp1 / d
248 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
249 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
251 ap( kc+k-1 ) = ap( kc+k-1 ) -
252 $ zdotu( k-1, work, 1, ap( kc ), 1 )
253 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
254 $ zdotu( k-1, ap( kc ), 1, ap( kcnext ),
256 CALL zcopy( k-1, ap( kcnext ), 1, work, 1 )
257 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero,
259 ap( kcnext+k ) = ap( kcnext+k ) -
260 $ zdotu( k-1, work, 1, ap( kcnext ), 1 )
263 kcnext = kcnext + k + 1
266 kp = abs( ipiv( k ) )
272 kpc = ( kp-1 )*kp / 2 + 1
273 CALL zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
275 DO 40 j = kp + 1, k - 1
278 ap( kc+j-1 ) = ap( kx )
282 ap( kc+k-1 ) = ap( kpc+kp-1 )
283 ap( kpc+kp-1 ) = temp
284 IF( kstep.EQ.2 )
THEN
285 temp = ap( kc+k+k-1 )
286 ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
287 ap( kc+k+kp-1 ) = temp
313 kcnext = kc - ( n-k+2 )
314 IF( ipiv( k ).GT.0 )
THEN
320 ap( kc ) = one / ap( kc )
325 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
326 CALL zspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1,
327 $ zero, ap( kc+1 ), 1 )
328 ap( kc ) = ap( kc ) - zdotu( n-k, work, 1, ap( kc+1 ),
339 ak = ap( kcnext ) / t
341 akkp1 = ap( kcnext+1 ) / t
342 d = t*( ak*akp1-one )
343 ap( kcnext ) = akp1 / d
345 ap( kcnext+1 ) = -akkp1 / d
350 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
351 CALL zspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
352 $ zero, ap( kc+1 ), 1 )
353 ap( kc ) = ap( kc ) - zdotu( n-k, work, 1, ap( kc+1 ),
355 ap( kcnext+1 ) = ap( kcnext+1 ) -
356 $ zdotu( n-k, ap( kc+1 ), 1,
357 $ ap( kcnext+2 ), 1 )
358 CALL zcopy( n-k, ap( kcnext+2 ), 1, work, 1 )
359 CALL zspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
360 $ zero, ap( kcnext+2 ), 1 )
361 ap( kcnext ) = ap( kcnext ) -
362 $ zdotu( n-k, work, 1, ap( kcnext+2 ), 1 )
365 kcnext = kcnext - ( n-k+3 )
368 kp = abs( ipiv( k ) )
374 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
376 $
CALL zswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
378 DO 70 j = k + 1, kp - 1
381 ap( kc+j-k ) = ap( kx )
387 IF( kstep.EQ.2 )
THEN
388 temp = ap( kc-n+k-1 )
389 ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
390 ap( kc-n+kp-1 ) = temp
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zsptri(UPLO, N, AP, IPIV, WORK, INFO)
ZSPTRI
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
ZSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix ...