LAPACK  3.7.0
LAPACK: Linear Algebra PACKage
subroutine ssytri_3x ( character  UPLO,
integer  N,
real, dimension( lda, * )  A,
integer  LDA,
real, dimension( * )  E,
integer, dimension( * )  IPIV,
real, dimension( n+nb+1, * )  WORK,
integer  NB,
integer  INFO 
)

SSYTRI_3X

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

Purpose: 
 SSYTRI_3X computes the inverse of a real symmetric indefinite
 matrix A using the factorization computed by SSYTRF_RK or SSYTRF_BK:

     A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),

 where U (or L) is unit upper (or lower) triangular matrix,
 U**T (or L**T) is the transpose of U (or L), P is a permutation
 matrix, P**T is the transpose of P, and D is symmetric and block
 diagonal with 1-by-1 and 2-by-2 diagonal blocks.

 This is the blocked version of the algorithm, calling Level 3 BLAS.
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 triangle of A is stored;
          = 'L':  Lower triangle of A is stored.
[in]N
          N is INTEGER
          The order of the matrix A.  N >= 0.
[in,out]A
          A is REAL array, dimension (LDA,N)
          On entry, diagonal of the block diagonal matrix D and
          factors U or L as computed by SYTRF_RK and SSYTRF_BK:
            a) ONLY diagonal elements of the symmetric block diagonal
               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
               (superdiagonal (or subdiagonal) elements of D
                should be provided on entry in array E), and
            b) If UPLO = 'U': factor U in the superdiagonal part of A.
               If UPLO = 'L': factor L in the subdiagonal part of A.

          On exit, if INFO = 0, the symmetric 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]E
          E is REAL array, dimension (N)
          On entry, contains the superdiagonal (or subdiagonal)
          elements of the symmetric block diagonal matrix D
          with 1-by-1 or 2-by-2 diagonal blocks, where
          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.

          NOTE: For 1-by-1 diagonal block D(k), where
          1 <= k <= N, the element E(k) is not referenced in both
          UPLO = 'U' or UPLO = 'L' cases.
[in]IPIV
          IPIV is INTEGER array, dimension (N)
          Details of the interchanges and the block structure of D
          as determined by SSYTRF_RK or SSYTRF_BK.
[out]WORK
          WORK is REAL array, dimension (N+NB+1,NB+3).
[in]NB
          NB is INTEGER
          Block size.
[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.
Date
December 2016
Contributors:

December 2016, Igor Kozachenko, Computer Science Division, University of California, Berkeley

Definition at line 161 of file ssytri_3x.f.

161 *
162 * -- LAPACK computational routine (version 3.7.0) --
163 * -- LAPACK is a software package provided by Univ. of Tennessee, --
164 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
165 * December 2016
166 *
167 * .. Scalar Arguments ..
168  CHARACTER uplo
169  INTEGER info, lda, n, nb
170 * ..
171 * .. Array Arguments ..
172  INTEGER ipiv( * )
173  REAL a( lda, * ), e( * ), work( n+nb+1, * )
174 * ..
175 *
176 * =====================================================================
177 *
178 * .. Parameters ..
179  REAL one, zero
180  parameter ( one = 1.0e+0, zero = 0.0e+0 )
181 * ..
182 * .. Local Scalars ..
183  LOGICAL upper
184  INTEGER cut, i, icount, invd, ip, k, nnb, j, u11
185  REAL ak, akkp1, akp1, d, t, u01_i_j, u01_ip1_j,
186  $ u11_i_j, u11_ip1_j
187 * ..
188 * .. External Functions ..
189  LOGICAL lsame
190  EXTERNAL lsame
191 * ..
192 * .. External Subroutines ..
193  EXTERNAL sgemm, ssyswapr, strtri, strmm, xerbla
194 * ..
195 * .. Intrinsic Functions ..
196  INTRINSIC abs, max, mod
197 * ..
198 * .. Executable Statements ..
199 *
200 * Test the input parameters.
201 *
202  info = 0
203  upper = lsame( uplo, 'U' )
204  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
205  info = -1
206  ELSE IF( n.LT.0 ) THEN
207  info = -2
208  ELSE IF( lda.LT.max( 1, n ) ) THEN
209  info = -4
210  END IF
211 *
212 * Quick return if possible
213 *
214  IF( info.NE.0 ) THEN
215  CALL xerbla( 'SSYTRI_3X', -info )
216  RETURN
217  END IF
218  IF( n.EQ.0 )
219  $ RETURN
220 *
221 * Workspace got Non-diag elements of D
222 *
223  DO k = 1, n
224  work( k, 1 ) = e( k )
225  END DO
226 *
227 * Check that the diagonal matrix D is nonsingular.
228 *
229  IF( upper ) THEN
230 *
231 * Upper triangular storage: examine D from bottom to top
232 *
233  DO info = n, 1, -1
234  IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
235  $ RETURN
236  END DO
237  ELSE
238 *
239 * Lower triangular storage: examine D from top to bottom.
240 *
241  DO info = 1, n
242  IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
243  $ RETURN
244  END DO
245  END IF
246 *
247  info = 0
248 *
249 * Splitting Workspace
250 * U01 is a block ( N, NB+1 )
251 * The first element of U01 is in WORK( 1, 1 )
252 * U11 is a block ( NB+1, NB+1 )
253 * The first element of U11 is in WORK( N+1, 1 )
254 *
255  u11 = n
256 *
257 * INVD is a block ( N, 2 )
258 * The first element of INVD is in WORK( 1, INVD )
259 *
260  invd = nb + 2
261 
262  IF( upper ) THEN
263 *
264 * Begin Upper
265 *
266 * invA = P * inv(U**T) * inv(D) * inv(U) * P**T.
267 *
268  CALL strtri( uplo, 'U', n, a, lda, info )
269 *
270 * inv(D) and inv(D) * inv(U)
271 *
272  k = 1
273  DO WHILE( k.LE.n )
274  IF( ipiv( k ).GT.0 ) THEN
275 * 1 x 1 diagonal NNB
276  work( k, invd ) = one / a( k, k )
277  work( k, invd+1 ) = zero
278  ELSE
279 * 2 x 2 diagonal NNB
280  t = work( k+1, 1 )
281  ak = a( k, k ) / t
282  akp1 = a( k+1, k+1 ) / t
283  akkp1 = work( k+1, 1 ) / t
284  d = t*( ak*akp1-one )
285  work( k, invd ) = akp1 / d
286  work( k+1, invd+1 ) = ak / d
287  work( k, invd+1 ) = -akkp1 / d
288  work( k+1, invd ) = work( k, invd+1 )
289  k = k + 1
290  END IF
291  k = k + 1
292  END DO
293 *
294 * inv(U**T) = (inv(U))**T
295 *
296 * inv(U**T) * inv(D) * inv(U)
297 *
298  cut = n
299  DO WHILE( cut.GT.0 )
300  nnb = nb
301  IF( cut.LE.nnb ) THEN
302  nnb = cut
303  ELSE
304  icount = 0
305 * count negative elements,
306  DO i = cut+1-nnb, cut
307  IF( ipiv( i ).LT.0 ) icount = icount + 1
308  END DO
309 * need a even number for a clear cut
310  IF( mod( icount, 2 ).EQ.1 ) nnb = nnb + 1
311  END IF
312 
313  cut = cut - nnb
314 *
315 * U01 Block
316 *
317  DO i = 1, cut
318  DO j = 1, nnb
319  work( i, j ) = a( i, cut+j )
320  END DO
321  END DO
322 *
323 * U11 Block
324 *
325  DO i = 1, nnb
326  work( u11+i, i ) = one
327  DO j = 1, i-1
328  work( u11+i, j ) = zero
329  END DO
330  DO j = i+1, nnb
331  work( u11+i, j ) = a( cut+i, cut+j )
332  END DO
333  END DO
334 *
335 * invD * U01
336 *
337  i = 1
338  DO WHILE( i.LE.cut )
339  IF( ipiv( i ).GT.0 ) THEN
340  DO j = 1, nnb
341  work( i, j ) = work( i, invd ) * work( i, j )
342  END DO
343  ELSE
344  DO j = 1, nnb
345  u01_i_j = work( i, j )
346  u01_ip1_j = work( i+1, j )
347  work( i, j ) = work( i, invd ) * u01_i_j
348  $ + work( i, invd+1 ) * u01_ip1_j
349  work( i+1, j ) = work( i+1, invd ) * u01_i_j
350  $ + work( i+1, invd+1 ) * u01_ip1_j
351  END DO
352  i = i + 1
353  END IF
354  i = i + 1
355  END DO
356 *
357 * invD1 * U11
358 *
359  i = 1
360  DO WHILE ( i.LE.nnb )
361  IF( ipiv( cut+i ).GT.0 ) THEN
362  DO j = i, nnb
363  work( u11+i, j ) = work(cut+i,invd) * work(u11+i,j)
364  END DO
365  ELSE
366  DO j = i, nnb
367  u11_i_j = work(u11+i,j)
368  u11_ip1_j = work(u11+i+1,j)
369  work( u11+i, j ) = work(cut+i,invd) * work(u11+i,j)
370  $ + work(cut+i,invd+1) * work(u11+i+1,j)
371  work( u11+i+1, j ) = work(cut+i+1,invd) * u11_i_j
372  $ + work(cut+i+1,invd+1) * u11_ip1_j
373  END DO
374  i = i + 1
375  END IF
376  i = i + 1
377  END DO
378 *
379 * U11**T * invD1 * U11 -> U11
380 *
381  CALL strmm( 'L', 'U', 'T', 'U', nnb, nnb,
382  $ one, a( cut+1, cut+1 ), lda, work( u11+1, 1 ),
383  $ n+nb+1 )
384 *
385  DO i = 1, nnb
386  DO j = i, nnb
387  a( cut+i, cut+j ) = work( u11+i, j )
388  END DO
389  END DO
390 *
391 * U01**T * invD * U01 -> A( CUT+I, CUT+J )
392 *
393  CALL sgemm( 'T', 'N', nnb, nnb, cut, one, a( 1, cut+1 ),
394  $ lda, work, n+nb+1, zero, work(u11+1,1), n+nb+1 )
395 
396 *
397 * U11 = U11**T * invD1 * U11 + U01**T * invD * U01
398 *
399  DO i = 1, nnb
400  DO j = i, nnb
401  a( cut+i, cut+j ) = a( cut+i, cut+j ) + work(u11+i,j)
402  END DO
403  END DO
404 *
405 * U01 = U00**T * invD0 * U01
406 *
407  CALL strmm( 'L', uplo, 'T', 'U', cut, nnb,
408  $ one, a, lda, work, n+nb+1 )
409 
410 *
411 * Update U01
412 *
413  DO i = 1, cut
414  DO j = 1, nnb
415  a( i, cut+j ) = work( i, j )
416  END DO
417  END DO
418 *
419 * Next Block
420 *
421  END DO
422 *
423 * Apply PERMUTATIONS P and P**T:
424 * P * inv(U**T) * inv(D) * inv(U) * P**T.
425 * Interchange rows and columns I and IPIV(I) in reverse order
426 * from the formation order of IPIV vector for Upper case.
427 *
428 * ( We can use a loop over IPIV with increment 1,
429 * since the ABS value of IPIV(I) represents the row (column)
430 * index of the interchange with row (column) i in both 1x1
431 * and 2x2 pivot cases, i.e. we don't need separate code branches
432 * for 1x1 and 2x2 pivot cases )
433 *
434  DO i = 1, n
435  ip = abs( ipiv( i ) )
436  IF( ip.NE.i ) THEN
437  IF (i .LT. ip) CALL ssyswapr( uplo, n, a, lda, i ,ip )
438  IF (i .GT. ip) CALL ssyswapr( uplo, n, a, lda, ip ,i )
439  END IF
440  END DO
441 *
442  ELSE
443 *
444 * Begin Lower
445 *
446 * inv A = P * inv(L**T) * inv(D) * inv(L) * P**T.
447 *
448  CALL strtri( uplo, 'U', n, a, lda, info )
449 *
450 * inv(D) and inv(D) * inv(L)
451 *
452  k = n
453  DO WHILE ( k .GE. 1 )
454  IF( ipiv( k ).GT.0 ) THEN
455 * 1 x 1 diagonal NNB
456  work( k, invd ) = one / a( k, k )
457  work( k, invd+1 ) = zero
458  ELSE
459 * 2 x 2 diagonal NNB
460  t = work( k-1, 1 )
461  ak = a( k-1, k-1 ) / t
462  akp1 = a( k, k ) / t
463  akkp1 = work( k-1, 1 ) / t
464  d = t*( ak*akp1-one )
465  work( k-1, invd ) = akp1 / d
466  work( k, invd ) = ak / d
467  work( k, invd+1 ) = -akkp1 / d
468  work( k-1, invd+1 ) = work( k, invd+1 )
469  k = k - 1
470  END IF
471  k = k - 1
472  END DO
473 *
474 * inv(L**T) = (inv(L))**T
475 *
476 * inv(L**T) * inv(D) * inv(L)
477 *
478  cut = 0
479  DO WHILE( cut.LT.n )
480  nnb = nb
481  IF( (cut + nnb).GT.n ) THEN
482  nnb = n - cut
483  ELSE
484  icount = 0
485 * count negative elements,
486  DO i = cut + 1, cut+nnb
487  IF ( ipiv( i ).LT.0 ) icount = icount + 1
488  END DO
489 * need a even number for a clear cut
490  IF( mod( icount, 2 ).EQ.1 ) nnb = nnb + 1
491  END IF
492 *
493 * L21 Block
494 *
495  DO i = 1, n-cut-nnb
496  DO j = 1, nnb
497  work( i, j ) = a( cut+nnb+i, cut+j )
498  END DO
499  END DO
500 *
501 * L11 Block
502 *
503  DO i = 1, nnb
504  work( u11+i, i) = one
505  DO j = i+1, nnb
506  work( u11+i, j ) = zero
507  END DO
508  DO j = 1, i-1
509  work( u11+i, j ) = a( cut+i, cut+j )
510  END DO
511  END DO
512 *
513 * invD*L21
514 *
515  i = n-cut-nnb
516  DO WHILE( i.GE.1 )
517  IF( ipiv( cut+nnb+i ).GT.0 ) THEN
518  DO j = 1, nnb
519  work( i, j ) = work( cut+nnb+i, invd) * work( i, j)
520  END DO
521  ELSE
522  DO j = 1, nnb
523  u01_i_j = work(i,j)
524  u01_ip1_j = work(i-1,j)
525  work(i,j)=work(cut+nnb+i,invd)*u01_i_j+
526  $ work(cut+nnb+i,invd+1)*u01_ip1_j
527  work(i-1,j)=work(cut+nnb+i-1,invd+1)*u01_i_j+
528  $ work(cut+nnb+i-1,invd)*u01_ip1_j
529  END DO
530  i = i - 1
531  END IF
532  i = i - 1
533  END DO
534 *
535 * invD1*L11
536 *
537  i = nnb
538  DO WHILE( i.GE.1 )
539  IF( ipiv( cut+i ).GT.0 ) THEN
540  DO j = 1, nnb
541  work( u11+i, j ) = work( cut+i, invd)*work(u11+i,j)
542  END DO
543 
544  ELSE
545  DO j = 1, nnb
546  u11_i_j = work( u11+i, j )
547  u11_ip1_j = work( u11+i-1, j )
548  work( u11+i, j ) = work(cut+i,invd) * work(u11+i,j)
549  $ + work(cut+i,invd+1) * u11_ip1_j
550  work( u11+i-1, j ) = work(cut+i-1,invd+1) * u11_i_j
551  $ + work(cut+i-1,invd) * u11_ip1_j
552  END DO
553  i = i - 1
554  END IF
555  i = i - 1
556  END DO
557 *
558 * L11**T * invD1 * L11 -> L11
559 *
560  CALL strmm( 'L', uplo, 'T', 'U', nnb, nnb, one,
561  $ a( cut+1, cut+1 ), lda, work( u11+1, 1 ),
562  $ n+nb+1 )
563 
564 *
565  DO i = 1, nnb
566  DO j = 1, i
567  a( cut+i, cut+j ) = work( u11+i, j )
568  END DO
569  END DO
570 *
571  IF( (cut+nnb).LT.n ) THEN
572 *
573 * L21**T * invD2*L21 -> A( CUT+I, CUT+J )
574 *
575  CALL sgemm( 'T', 'N', nnb, nnb, n-nnb-cut, one,
576  $ a( cut+nnb+1, cut+1 ), lda, work, n+nb+1,
577  $ zero, work( u11+1, 1 ), n+nb+1 )
578 
579 *
580 * L11 = L11**T * invD1 * L11 + U01**T * invD * U01
581 *
582  DO i = 1, nnb
583  DO j = 1, i
584  a( cut+i, cut+j ) = a( cut+i, cut+j )+work(u11+i,j)
585  END DO
586  END DO
587 *
588 * L01 = L22**T * invD2 * L21
589 *
590  CALL strmm( 'L', uplo, 'T', 'U', n-nnb-cut, nnb, one,
591  $ a( cut+nnb+1, cut+nnb+1 ), lda, work,
592  $ n+nb+1 )
593 *
594 * Update L21
595 *
596  DO i = 1, n-cut-nnb
597  DO j = 1, nnb
598  a( cut+nnb+i, cut+j ) = work( i, j )
599  END DO
600  END DO
601 *
602  ELSE
603 *
604 * L11 = L11**T * invD1 * L11
605 *
606  DO i = 1, nnb
607  DO j = 1, i
608  a( cut+i, cut+j ) = work( u11+i, j )
609  END DO
610  END DO
611  END IF
612 *
613 * Next Block
614 *
615  cut = cut + nnb
616 *
617  END DO
618 *
619 * Apply PERMUTATIONS P and P**T:
620 * P * inv(L**T) * inv(D) * inv(L) * P**T.
621 * Interchange rows and columns I and IPIV(I) in reverse order
622 * from the formation order of IPIV vector for Lower case.
623 *
624 * ( We can use a loop over IPIV with increment -1,
625 * since the ABS value of IPIV(I) represents the row (column)
626 * index of the interchange with row (column) i in both 1x1
627 * and 2x2 pivot cases, i.e. we don't need separate code branches
628 * for 1x1 and 2x2 pivot cases )
629 *
630  DO i = n, 1, -1
631  ip = abs( ipiv( i ) )
632  IF( ip.NE.i ) THEN
633  IF (i .LT. ip) CALL ssyswapr( uplo, n, a, lda, i ,ip )
634  IF (i .GT. ip) CALL ssyswapr( uplo, n, a, lda, ip ,i )
635  END IF
636  END DO
637 *
638  END IF
639 *
640  RETURN
641 *
642 * End of SSYTRI_3X
643 *
sgemm
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
Definition: sgemm.f:189
strmm
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
Definition: strmm.f:179
strtri
subroutine strtri(UPLO, DIAG, N, A, LDA, INFO)
STRTRI
Definition: strtri.f:111
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
ssyswapr
subroutine ssyswapr(UPLO, N, A, LDA, I1, I2)
SSYSWAPR applies an elementary permutation on the rows and columns of a symmetric matrix...
Definition: ssyswapr.f:104
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55

Here is the call graph for this function:

Here is the caller graph for this function: