108 SUBROUTINE zsptri( UPLO, N, AP, IPIV, WORK, INFO )
120 COMPLEX*16 AP( * ), WORK( * )
127 parameter( one = ( 1.0d+0, 0.0d+0 ),
128 $ zero = ( 0.0d+0, 0.0d+0 ) )
132 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
133 COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
138 EXTERNAL lsame, zdotu
151 upper = lsame( uplo,
'U' )
152 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
154 ELSE IF( n.LT.0 )
THEN
158 CALL xerbla(
'ZSPTRI', -info )
174 DO 10 info = n, 1, -1
175 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
185 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
187 kp = kp + n - info + 1
209 IF( ipiv( k ).GT.0 )
THEN
215 ap( kc+k-1 ) = one / ap( kc+k-1 )
220 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
221 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
223 ap( kc+k-1 ) = ap( kc+k-1 ) -
224 $ zdotu( k-1, work, 1, ap( kc ), 1 )
234 ak = ap( kc+k-1 ) / t
235 akp1 = ap( kcnext+k ) / t
236 akkp1 = ap( kcnext+k-1 ) / t
237 d = t*( ak*akp1-one )
238 ap( kc+k-1 ) = akp1 / d
239 ap( kcnext+k ) = ak / d
240 ap( kcnext+k-1 ) = -akkp1 / d
245 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
246 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
248 ap( kc+k-1 ) = ap( kc+k-1 ) -
249 $ zdotu( k-1, work, 1, ap( kc ), 1 )
250 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
251 $ zdotu( k-1, ap( kc ), 1, ap( kcnext ),
253 CALL zcopy( k-1, ap( kcnext ), 1, work, 1 )
254 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero,
256 ap( kcnext+k ) = ap( kcnext+k ) -
257 $ zdotu( k-1, work, 1, ap( kcnext ), 1 )
260 kcnext = kcnext + k + 1
263 kp = abs( ipiv( k ) )
269 kpc = ( kp-1 )*kp / 2 + 1
270 CALL zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
272 DO 40 j = kp + 1, k - 1
275 ap( kc+j-1 ) = ap( kx )
279 ap( kc+k-1 ) = ap( kpc+kp-1 )
280 ap( kpc+kp-1 ) = temp
281 IF( kstep.EQ.2 )
THEN
282 temp = ap( kc+k+k-1 )
283 ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
284 ap( kc+k+kp-1 ) = temp
310 kcnext = kc - ( n-k+2 )
311 IF( ipiv( k ).GT.0 )
THEN
317 ap( kc ) = one / ap( kc )
322 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
323 CALL zspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1,
324 $ zero, ap( kc+1 ), 1 )
325 ap( kc ) = ap( kc ) - zdotu( n-k, work, 1, ap( kc+1 ),
336 ak = ap( kcnext ) / t
338 akkp1 = ap( kcnext+1 ) / t
339 d = t*( ak*akp1-one )
340 ap( kcnext ) = akp1 / d
342 ap( kcnext+1 ) = -akkp1 / d
347 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
348 CALL zspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
349 $ zero, ap( kc+1 ), 1 )
350 ap( kc ) = ap( kc ) - zdotu( n-k, work, 1, ap( kc+1 ),
352 ap( kcnext+1 ) = ap( kcnext+1 ) -
353 $ zdotu( n-k, ap( kc+1 ), 1,
354 $ ap( kcnext+2 ), 1 )
355 CALL zcopy( n-k, ap( kcnext+2 ), 1, work, 1 )
356 CALL zspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
357 $ zero, ap( kcnext+2 ), 1 )
358 ap( kcnext ) = ap( kcnext ) -
359 $ zdotu( n-k, work, 1, ap( kcnext+2 ), 1 )
362 kcnext = kcnext - ( n-k+3 )
365 kp = abs( ipiv( k ) )
371 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
373 $
CALL zswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
375 DO 70 j = k + 1, kp - 1
378 ap( kc+j-k ) = ap( kx )
384 IF( kstep.EQ.2 )
THEN
385 temp = ap( kc-n+k-1 )
386 ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
387 ap( kc-n+kp-1 ) = temp
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
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
subroutine zsptri(UPLO, N, AP, IPIV, WORK, INFO)
ZSPTRI