LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zhetri_rook()

subroutine zhetri_rook ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex*16, dimension( * ) work,
integer info )

ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method.

Download ZHETRI_ROOK + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> ZHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix
!> A using the factorization A = U*D*U**H or A = L*D*L**H computed by
!> ZHETRF_ROOK.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the block diagonal matrix D and the multipliers
!>          used to obtain the factor U or L as computed by ZHETRF_ROOK.
!>
!>          On exit, if INFO = 0, the (Hermitian) inverse of the original
!>          matrix.  If UPLO = 'U', the upper triangular part of the
!>          inverse is formed and the part of A below the diagonal is not
!>          referenced; if UPLO = 'L' the lower triangular part of the
!>          inverse is formed and the part of A above the diagonal is
!>          not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHETRF_ROOK.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
!>               inverse could not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>  November 2013,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>

Definition at line 125 of file zhetri_rook.f.

126*
127* -- LAPACK computational routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 CHARACTER UPLO
133 INTEGER INFO, LDA, N
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 COMPLEX*16 A( LDA, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ONE
144 COMPLEX*16 CONE, CZERO
145 parameter( one = 1.0d+0, cone = ( 1.0d+0, 0.0d+0 ),
146 $ czero = ( 0.0d+0, 0.0d+0 ) )
147* ..
148* .. Local Scalars ..
149 LOGICAL UPPER
150 INTEGER J, K, KP, KSTEP
151 DOUBLE PRECISION AK, AKP1, D, T
152 COMPLEX*16 AKKP1, TEMP
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 COMPLEX*16 ZDOTC
157 EXTERNAL lsame, zdotc
158* ..
159* .. External Subroutines ..
160 EXTERNAL zcopy, zhemv, zswap, xerbla
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC abs, dconjg, max, dble
164* ..
165* .. Executable Statements ..
166*
167* Test the input parameters.
168*
169 info = 0
170 upper = lsame( uplo, 'U' )
171 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
172 info = -1
173 ELSE IF( n.LT.0 ) THEN
174 info = -2
175 ELSE IF( lda.LT.max( 1, n ) ) THEN
176 info = -4
177 END IF
178 IF( info.NE.0 ) THEN
179 CALL xerbla( 'ZHETRI_ROOK', -info )
180 RETURN
181 END IF
182*
183* Quick return if possible
184*
185 IF( n.EQ.0 )
186 $ RETURN
187*
188* Check that the diagonal matrix D is nonsingular.
189*
190 IF( upper ) THEN
191*
192* Upper triangular storage: examine D from bottom to top
193*
194 DO 10 info = n, 1, -1
195 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.czero )
196 $ RETURN
197 10 CONTINUE
198 ELSE
199*
200* Lower triangular storage: examine D from top to bottom.
201*
202 DO 20 info = 1, n
203 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.czero )
204 $ RETURN
205 20 CONTINUE
206 END IF
207 info = 0
208*
209 IF( upper ) THEN
210*
211* Compute inv(A) from the factorization A = U*D*U**H.
212*
213* K is the main loop index, increasing from 1 to N in steps of
214* 1 or 2, depending on the size of the diagonal blocks.
215*
216 k = 1
217 30 CONTINUE
218*
219* If K > N, exit from loop.
220*
221 IF( k.GT.n )
222 $ GO TO 70
223*
224 IF( ipiv( k ).GT.0 ) THEN
225*
226* 1 x 1 diagonal block
227*
228* Invert the diagonal block.
229*
230 a( k, k ) = one / dble( a( k, k ) )
231*
232* Compute column K of the inverse.
233*
234 IF( k.GT.1 ) THEN
235 CALL zcopy( k-1, a( 1, k ), 1, work, 1 )
236 CALL zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,
237 $ a( 1, k ), 1 )
238 a( k, k ) = a( k, k ) - dble( zdotc( k-1, work, 1,
239 $ a( 1,
240 $ k ), 1 ) )
241 END IF
242 kstep = 1
243 ELSE
244*
245* 2 x 2 diagonal block
246*
247* Invert the diagonal block.
248*
249 t = abs( a( k, k+1 ) )
250 ak = dble( a( k, k ) ) / t
251 akp1 = dble( a( k+1, k+1 ) ) / t
252 akkp1 = a( k, k+1 ) / t
253 d = t*( ak*akp1-one )
254 a( k, k ) = akp1 / d
255 a( k+1, k+1 ) = ak / d
256 a( k, k+1 ) = -akkp1 / d
257*
258* Compute columns K and K+1 of the inverse.
259*
260 IF( k.GT.1 ) THEN
261 CALL zcopy( k-1, a( 1, k ), 1, work, 1 )
262 CALL zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,
263 $ a( 1, k ), 1 )
264 a( k, k ) = a( k, k ) - dble( zdotc( k-1, work, 1,
265 $ a( 1,
266 $ k ), 1 ) )
267 a( k, k+1 ) = a( k, k+1 ) -
268 $ zdotc( k-1, a( 1, k ), 1, a( 1, k+1 ),
269 $ 1 )
270 CALL zcopy( k-1, a( 1, k+1 ), 1, work, 1 )
271 CALL zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,
272 $ a( 1, k+1 ), 1 )
273 a( k+1, k+1 ) = a( k+1, k+1 ) -
274 $ dble( zdotc( k-1, work, 1, a( 1,
275 $ k+1 ),
276 $ 1 ) )
277 END IF
278 kstep = 2
279 END IF
280*
281 IF( kstep.EQ.1 ) THEN
282*
283* Interchange rows and columns K and IPIV(K) in the leading
284* submatrix A(1:k,1:k)
285*
286 kp = ipiv( k )
287 IF( kp.NE.k ) THEN
288*
289 IF( kp.GT.1 )
290 $ CALL zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
291*
292 DO 40 j = kp + 1, k - 1
293 temp = dconjg( a( j, k ) )
294 a( j, k ) = dconjg( a( kp, j ) )
295 a( kp, j ) = temp
296 40 CONTINUE
297*
298 a( kp, k ) = dconjg( a( kp, k ) )
299*
300 temp = a( k, k )
301 a( k, k ) = a( kp, kp )
302 a( kp, kp ) = temp
303 END IF
304 ELSE
305*
306* Interchange rows and columns K and K+1 with -IPIV(K) and
307* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n)
308*
309* (1) Interchange rows and columns K and -IPIV(K)
310*
311 kp = -ipiv( k )
312 IF( kp.NE.k ) THEN
313*
314 IF( kp.GT.1 )
315 $ CALL zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
316*
317 DO 50 j = kp + 1, k - 1
318 temp = dconjg( a( j, k ) )
319 a( j, k ) = dconjg( a( kp, j ) )
320 a( kp, j ) = temp
321 50 CONTINUE
322*
323 a( kp, k ) = dconjg( a( kp, k ) )
324*
325 temp = a( k, k )
326 a( k, k ) = a( kp, kp )
327 a( kp, kp ) = temp
328*
329 temp = a( k, k+1 )
330 a( k, k+1 ) = a( kp, k+1 )
331 a( kp, k+1 ) = temp
332 END IF
333*
334* (2) Interchange rows and columns K+1 and -IPIV(K+1)
335*
336 k = k + 1
337 kp = -ipiv( k )
338 IF( kp.NE.k ) THEN
339*
340 IF( kp.GT.1 )
341 $ CALL zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
342*
343 DO 60 j = kp + 1, k - 1
344 temp = dconjg( a( j, k ) )
345 a( j, k ) = dconjg( a( kp, j ) )
346 a( kp, j ) = temp
347 60 CONTINUE
348*
349 a( kp, k ) = dconjg( a( kp, k ) )
350*
351 temp = a( k, k )
352 a( k, k ) = a( kp, kp )
353 a( kp, kp ) = temp
354 END IF
355 END IF
356*
357 k = k + 1
358 GO TO 30
359 70 CONTINUE
360*
361 ELSE
362*
363* Compute inv(A) from the factorization A = L*D*L**H.
364*
365* K is the main loop index, decreasing from N to 1 in steps of
366* 1 or 2, depending on the size of the diagonal blocks.
367*
368 k = n
369 80 CONTINUE
370*
371* If K < 1, exit from loop.
372*
373 IF( k.LT.1 )
374 $ GO TO 120
375*
376 IF( ipiv( k ).GT.0 ) THEN
377*
378* 1 x 1 diagonal block
379*
380* Invert the diagonal block.
381*
382 a( k, k ) = one / dble( a( k, k ) )
383*
384* Compute column K of the inverse.
385*
386 IF( k.LT.n ) THEN
387 CALL zcopy( n-k, a( k+1, k ), 1, work, 1 )
388 CALL zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda,
389 $ work,
390 $ 1, czero, a( k+1, k ), 1 )
391 a( k, k ) = a( k, k ) - dble( zdotc( n-k, work, 1,
392 $ a( k+1, k ), 1 ) )
393 END IF
394 kstep = 1
395 ELSE
396*
397* 2 x 2 diagonal block
398*
399* Invert the diagonal block.
400*
401 t = abs( a( k, k-1 ) )
402 ak = dble( a( k-1, k-1 ) ) / t
403 akp1 = dble( a( k, k ) ) / t
404 akkp1 = a( k, k-1 ) / t
405 d = t*( ak*akp1-one )
406 a( k-1, k-1 ) = akp1 / d
407 a( k, k ) = ak / d
408 a( k, k-1 ) = -akkp1 / d
409*
410* Compute columns K-1 and K of the inverse.
411*
412 IF( k.LT.n ) THEN
413 CALL zcopy( n-k, a( k+1, k ), 1, work, 1 )
414 CALL zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda,
415 $ work,
416 $ 1, czero, a( k+1, k ), 1 )
417 a( k, k ) = a( k, k ) - dble( zdotc( n-k, work, 1,
418 $ a( k+1, k ), 1 ) )
419 a( k, k-1 ) = a( k, k-1 ) -
420 $ zdotc( n-k, a( k+1, k ), 1, a( k+1,
421 $ k-1 ),
422 $ 1 )
423 CALL zcopy( n-k, a( k+1, k-1 ), 1, work, 1 )
424 CALL zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda,
425 $ work,
426 $ 1, czero, a( k+1, k-1 ), 1 )
427 a( k-1, k-1 ) = a( k-1, k-1 ) -
428 $ dble( zdotc( n-k, work, 1, a( k+1,
429 $ k-1 ),
430 $ 1 ) )
431 END IF
432 kstep = 2
433 END IF
434*
435 IF( kstep.EQ.1 ) THEN
436*
437* Interchange rows and columns K and IPIV(K) in the trailing
438* submatrix A(k:n,k:n)
439*
440 kp = ipiv( k )
441 IF( kp.NE.k ) THEN
442*
443 IF( kp.LT.n )
444 $ CALL zswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ),
445 $ 1 )
446*
447 DO 90 j = k + 1, kp - 1
448 temp = dconjg( a( j, k ) )
449 a( j, k ) = dconjg( a( kp, j ) )
450 a( kp, j ) = temp
451 90 CONTINUE
452*
453 a( kp, k ) = dconjg( a( kp, k ) )
454*
455 temp = a( k, k )
456 a( k, k ) = a( kp, kp )
457 a( kp, kp ) = temp
458 END IF
459 ELSE
460*
461* Interchange rows and columns K and K-1 with -IPIV(K) and
462* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
463*
464* (1) Interchange rows and columns K and -IPIV(K)
465*
466 kp = -ipiv( k )
467 IF( kp.NE.k ) THEN
468*
469 IF( kp.LT.n )
470 $ CALL zswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ),
471 $ 1 )
472*
473 DO 100 j = k + 1, kp - 1
474 temp = dconjg( a( j, k ) )
475 a( j, k ) = dconjg( a( kp, j ) )
476 a( kp, j ) = temp
477 100 CONTINUE
478*
479 a( kp, k ) = dconjg( a( kp, k ) )
480*
481 temp = a( k, k )
482 a( k, k ) = a( kp, kp )
483 a( kp, kp ) = temp
484*
485 temp = a( k, k-1 )
486 a( k, k-1 ) = a( kp, k-1 )
487 a( kp, k-1 ) = temp
488 END IF
489*
490* (2) Interchange rows and columns K-1 and -IPIV(K-1)
491*
492 k = k - 1
493 kp = -ipiv( k )
494 IF( kp.NE.k ) THEN
495*
496 IF( kp.LT.n )
497 $ CALL zswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ),
498 $ 1 )
499*
500 DO 110 j = k + 1, kp - 1
501 temp = dconjg( a( j, k ) )
502 a( j, k ) = dconjg( a( kp, j ) )
503 a( kp, j ) = temp
504 110 CONTINUE
505*
506 a( kp, k ) = dconjg( a( kp, k ) )
507*
508 temp = a( k, k )
509 a( k, k ) = a( kp, kp )
510 a( kp, kp ) = temp
511 END IF
512 END IF
513*
514 k = k - 1
515 GO TO 80
516 120 CONTINUE
517 END IF
518*
519 RETURN
520*
521* End of ZHETRI_ROOK
522*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83
zhemv
subroutine zhemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
ZHEMV
Definition zhemv.f:154
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
Here is the call graph for this function:
Here is the caller graph for this function: