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
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 zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
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 xerbla(SRNAME, INFO)
XERBLA
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
logical function lsame(CA, CB)
LSAME
subroutine zsptri(UPLO, N, AP, IPIV, WORK, INFO)
ZSPTRI
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
complex *16 function zdotu(N, ZX, INCX, ZY, INCY)
ZDOTU