LAPACK  3.8.0
LAPACK: Linear Algebra PACKage
zsptri.f
Go to the documentation of this file.
1 *> \brief \b ZSPTRI
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download ZSPTRI + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsptri.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsptri.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsptri.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
22 *
23 * .. Scalar Arguments ..
24 * CHARACTER UPLO
25 * INTEGER INFO, N
26 * ..
27 * .. Array Arguments ..
28 * INTEGER IPIV( * )
29 * COMPLEX*16 AP( * ), WORK( * )
30 * ..
31 *
32 *
33 *> \par Purpose:
34 * =============
35 *>
36 *> \verbatim
37 *>
38 *> ZSPTRI computes the inverse of a complex symmetric indefinite matrix
39 *> A in packed storage using the factorization A = U*D*U**T or
40 *> A = L*D*L**T computed by ZSPTRF.
41 *> \endverbatim
42 *
43 * Arguments:
44 * ==========
45 *
46 *> \param[in] UPLO
47 *> \verbatim
48 *> UPLO is CHARACTER*1
49 *> Specifies whether the details of the factorization are stored
50 *> as an upper or lower triangular matrix.
51 *> = 'U': Upper triangular, form is A = U*D*U**T;
52 *> = 'L': Lower triangular, form is A = L*D*L**T.
53 *> \endverbatim
54 *>
55 *> \param[in] N
56 *> \verbatim
57 *> N is INTEGER
58 *> The order of the matrix A. N >= 0.
59 *> \endverbatim
60 *>
61 *> \param[in,out] AP
62 *> \verbatim
63 *> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
64 *> On entry, the block diagonal matrix D and the multipliers
65 *> used to obtain the factor U or L as computed by ZSPTRF,
66 *> stored as a packed triangular matrix.
67 *>
68 *> On exit, if INFO = 0, the (symmetric) inverse of the original
69 *> matrix, stored as a packed triangular matrix. The j-th column
70 *> of inv(A) is stored in the array AP as follows:
71 *> if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
72 *> if UPLO = 'L',
73 *> AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
74 *> \endverbatim
75 *>
76 *> \param[in] IPIV
77 *> \verbatim
78 *> IPIV is INTEGER array, dimension (N)
79 *> Details of the interchanges and the block structure of D
80 *> as determined by ZSPTRF.
81 *> \endverbatim
82 *>
83 *> \param[out] WORK
84 *> \verbatim
85 *> WORK is COMPLEX*16 array, dimension (N)
86 *> \endverbatim
87 *>
88 *> \param[out] INFO
89 *> \verbatim
90 *> INFO is INTEGER
91 *> = 0: successful exit
92 *> < 0: if INFO = -i, the i-th argument had an illegal value
93 *> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
94 *> inverse could not be computed.
95 *> \endverbatim
96 *
97 * Authors:
98 * ========
99 *
100 *> \author Univ. of Tennessee
101 *> \author Univ. of California Berkeley
102 *> \author Univ. of Colorado Denver
103 *> \author NAG Ltd.
104 *
105 *> \date December 2016
106 *
107 *> \ingroup complex16OTHERcomputational
108 *
109 * =====================================================================
110  SUBROUTINE zsptri( UPLO, N, AP, IPIV, WORK, INFO )
111 *
112 * -- LAPACK computational routine (version 3.7.0) --
113 * -- LAPACK is a software package provided by Univ. of Tennessee, --
114 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
115 * December 2016
116 *
117 * .. Scalar Arguments ..
118  CHARACTER UPLO
119  INTEGER INFO, N
120 * ..
121 * .. Array Arguments ..
122  INTEGER IPIV( * )
123  COMPLEX*16 AP( * ), WORK( * )
124 * ..
125 *
126 * =====================================================================
127 *
128 * .. Parameters ..
129  COMPLEX*16 ONE, ZERO
130  parameter( one = ( 1.0d+0, 0.0d+0 ),
131  $ zero = ( 0.0d+0, 0.0d+0 ) )
132 * ..
133 * .. Local Scalars ..
134  LOGICAL UPPER
135  INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
136  COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
137 * ..
138 * .. External Functions ..
139  LOGICAL LSAME
140  COMPLEX*16 ZDOTU
141  EXTERNAL lsame, zdotu
142 * ..
143 * .. External Subroutines ..
144  EXTERNAL xerbla, zcopy, zspmv, zswap
145 * ..
146 * .. Intrinsic Functions ..
147  INTRINSIC abs
148 * ..
149 * .. Executable Statements ..
150 *
151 * Test the input parameters.
152 *
153  info = 0
154  upper = lsame( uplo, 'U' )
155  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
156  info = -1
157  ELSE IF( n.LT.0 ) THEN
158  info = -2
159  END IF
160  IF( info.NE.0 ) THEN
161  CALL xerbla( 'ZSPTRI', -info )
162  RETURN
163  END IF
164 *
165 * Quick return if possible
166 *
167  IF( n.EQ.0 )
168  $ RETURN
169 *
170 * Check that the diagonal matrix D is nonsingular.
171 *
172  IF( upper ) THEN
173 *
174 * Upper triangular storage: examine D from bottom to top
175 *
176  kp = n*( n+1 ) / 2
177  DO 10 info = n, 1, -1
178  IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
179  $ RETURN
180  kp = kp - info
181  10 CONTINUE
182  ELSE
183 *
184 * Lower triangular storage: examine D from top to bottom.
185 *
186  kp = 1
187  DO 20 info = 1, n
188  IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
189  $ RETURN
190  kp = kp + n - info + 1
191  20 CONTINUE
192  END IF
193  info = 0
194 *
195  IF( upper ) THEN
196 *
197 * Compute inv(A) from the factorization A = U*D*U**T.
198 *
199 * K is the main loop index, increasing from 1 to N in steps of
200 * 1 or 2, depending on the size of the diagonal blocks.
201 *
202  k = 1
203  kc = 1
204  30 CONTINUE
205 *
206 * If K > N, exit from loop.
207 *
208  IF( k.GT.n )
209  $ GO TO 50
210 *
211  kcnext = kc + k
212  IF( ipiv( k ).GT.0 ) THEN
213 *
214 * 1 x 1 diagonal block
215 *
216 * Invert the diagonal block.
217 *
218  ap( kc+k-1 ) = one / ap( kc+k-1 )
219 *
220 * Compute column K of the inverse.
221 *
222  IF( k.GT.1 ) THEN
223  CALL zcopy( k-1, ap( kc ), 1, work, 1 )
224  CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
225  $ 1 )
226  ap( kc+k-1 ) = ap( kc+k-1 ) -
227  $ zdotu( k-1, work, 1, ap( kc ), 1 )
228  END IF
229  kstep = 1
230  ELSE
231 *
232 * 2 x 2 diagonal block
233 *
234 * Invert the diagonal block.
235 *
236  t = ap( kcnext+k-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
244 *
245 * Compute columns K and K+1 of the inverse.
246 *
247  IF( k.GT.1 ) THEN
248  CALL zcopy( k-1, ap( kc ), 1, work, 1 )
249  CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
250  $ 1 )
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 ),
255  $ 1 )
256  CALL zcopy( k-1, ap( kcnext ), 1, work, 1 )
257  CALL zspmv( uplo, k-1, -one, ap, work, 1, zero,
258  $ ap( kcnext ), 1 )
259  ap( kcnext+k ) = ap( kcnext+k ) -
260  $ zdotu( k-1, work, 1, ap( kcnext ), 1 )
261  END IF
262  kstep = 2
263  kcnext = kcnext + k + 1
264  END IF
265 *
266  kp = abs( ipiv( k ) )
267  IF( kp.NE.k ) THEN
268 *
269 * Interchange rows and columns K and KP in the leading
270 * submatrix A(1:k+1,1:k+1)
271 *
272  kpc = ( kp-1 )*kp / 2 + 1
273  CALL zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
274  kx = kpc + kp - 1
275  DO 40 j = kp + 1, k - 1
276  kx = kx + j - 1
277  temp = ap( kc+j-1 )
278  ap( kc+j-1 ) = ap( kx )
279  ap( kx ) = temp
280  40 CONTINUE
281  temp = ap( kc+k-1 )
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
288  END IF
289  END IF
290 *
291  k = k + kstep
292  kc = kcnext
293  GO TO 30
294  50 CONTINUE
295 *
296  ELSE
297 *
298 * Compute inv(A) from the factorization A = L*D*L**T.
299 *
300 * K is the main loop index, increasing from 1 to N in steps of
301 * 1 or 2, depending on the size of the diagonal blocks.
302 *
303  npp = n*( n+1 ) / 2
304  k = n
305  kc = npp
306  60 CONTINUE
307 *
308 * If K < 1, exit from loop.
309 *
310  IF( k.LT.1 )
311  $ GO TO 80
312 *
313  kcnext = kc - ( n-k+2 )
314  IF( ipiv( k ).GT.0 ) THEN
315 *
316 * 1 x 1 diagonal block
317 *
318 * Invert the diagonal block.
319 *
320  ap( kc ) = one / ap( kc )
321 *
322 * Compute column K of the inverse.
323 *
324  IF( k.LT.n ) THEN
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 ),
329  $ 1 )
330  END IF
331  kstep = 1
332  ELSE
333 *
334 * 2 x 2 diagonal block
335 *
336 * Invert the diagonal block.
337 *
338  t = ap( kcnext+1 )
339  ak = ap( kcnext ) / t
340  akp1 = ap( kc ) / t
341  akkp1 = ap( kcnext+1 ) / t
342  d = t*( ak*akp1-one )
343  ap( kcnext ) = akp1 / d
344  ap( kc ) = ak / d
345  ap( kcnext+1 ) = -akkp1 / d
346 *
347 * Compute columns K-1 and K of the inverse.
348 *
349  IF( k.LT.n ) THEN
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 ),
354  $ 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 )
363  END IF
364  kstep = 2
365  kcnext = kcnext - ( n-k+3 )
366  END IF
367 *
368  kp = abs( ipiv( k ) )
369  IF( kp.NE.k ) THEN
370 *
371 * Interchange rows and columns K and KP in the trailing
372 * submatrix A(k-1:n,k-1:n)
373 *
374  kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
375  IF( kp.LT.n )
376  $ CALL zswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
377  kx = kc + kp - k
378  DO 70 j = k + 1, kp - 1
379  kx = kx + n - j + 1
380  temp = ap( kc+j-k )
381  ap( kc+j-k ) = ap( kx )
382  ap( kx ) = temp
383  70 CONTINUE
384  temp = ap( kc )
385  ap( kc ) = ap( kpc )
386  ap( kpc ) = temp
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
391  END IF
392  END IF
393 *
394  k = k - kstep
395  kc = kcnext
396  GO TO 60
397  80 CONTINUE
398  END IF
399 *
400  RETURN
401 *
402 * End of ZSPTRI
403 *
404  END
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:83
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
Definition: zswap.f:83
subroutine zsptri(UPLO, N, AP, IPIV, WORK, INFO)
ZSPTRI
Definition: zsptri.f:111
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
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 ...
Definition: zspmv.f:153