OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
complex
LAPACK » Symmetric Matrix » Computational routines

Functions

subroutine chesv_aa_2stage (uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
  CHESV_AA_2STAGE computes the solution to system of linear equations A * X = B for HE matrices
subroutine chetrf_aa_2stage (uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
 CHETRF_AA_2STAGE
subroutine chetrs_aa_2stage (uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
 CHETRS_AA_2STAGE
subroutine cla_syamv (uplo, n, alpha, a, lda, x, incx, beta, y, incy)
 CLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds.
real function cla_syrcond_c (uplo, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
 CLA_SYRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for symmetric indefinite matrices.
real function cla_syrcond_x (uplo, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
 CLA_SYRCOND_X computes the infinity norm condition number of op(A)*diag(x) for symmetric indefinite matrices.
subroutine cla_syrfsx_extended (prec_type, uplo, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
 CLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric indefinite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.
real function cla_syrpvgrw (uplo, n, info, a, lda, af, ldaf, ipiv, work)
 CLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite matrix.
subroutine clahef_aa (uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
 CLAHEF_AA
subroutine clasyf (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
subroutine clasyf_aa (uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
 CLASYF_AA
subroutine clasyf_rk (uplo, n, nb, kb, a, lda, e, ipiv, w, ldw, info)
 CLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
subroutine clasyf_rook (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
subroutine csycon (uplo, n, a, lda, ipiv, anorm, rcond, work, info)
 CSYCON
subroutine csycon_3 (uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
 CSYCON_3
subroutine csycon_rook (uplo, n, a, lda, ipiv, anorm, rcond, work, info)
  CSYCON_ROOK
subroutine csyconv (uplo, way, n, a, lda, ipiv, e, info)
 CSYCONV
subroutine csyconvf (uplo, way, n, a, lda, e, ipiv, info)
 CSYCONVF
subroutine csyconvf_rook (uplo, way, n, a, lda, e, ipiv, info)
 CSYCONVF_ROOK
subroutine csyequb (uplo, n, a, lda, s, scond, amax, work, info)
 CSYEQUB
subroutine csyrfs (uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CSYRFS
subroutine csyrfsx (uplo, equed, n, nrhs, a, lda, af, ldaf, ipiv, s, b, ldb, x, ldx, rcond, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
 CSYRFSX
subroutine csysv_aa_2stage (uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
  CSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
subroutine csytf2 (uplo, n, a, lda, ipiv, info)
 CSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).
subroutine csytf2_rk (uplo, n, a, lda, e, ipiv, info)
 CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
subroutine csytf2_rook (uplo, n, a, lda, ipiv, info)
 CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
subroutine csytrf (uplo, n, a, lda, ipiv, work, lwork, info)
 CSYTRF
subroutine csytrf_aa (uplo, n, a, lda, ipiv, work, lwork, info)
 CSYTRF_AA
subroutine csytrf_aa_2stage (uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
 CSYTRF_AA_2STAGE
subroutine csytrf_rk (uplo, n, a, lda, e, ipiv, work, lwork, info)
 CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
subroutine csytrf_rook (uplo, n, a, lda, ipiv, work, lwork, info)
 CSYTRF_ROOK
subroutine csytri (uplo, n, a, lda, ipiv, work, info)
 CSYTRI
subroutine csytri2 (uplo, n, a, lda, ipiv, work, lwork, info)
 CSYTRI2
subroutine csytri2x (uplo, n, a, lda, ipiv, work, nb, info)
 CSYTRI2X
subroutine csytri_3 (uplo, n, a, lda, e, ipiv, work, lwork, info)
 CSYTRI_3
subroutine csytri_3x (uplo, n, a, lda, e, ipiv, work, nb, info)
 CSYTRI_3X
subroutine csytri_rook (uplo, n, a, lda, ipiv, work, info)
 CSYTRI_ROOK
subroutine csytrs (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 CSYTRS
subroutine csytrs2 (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
 CSYTRS2
subroutine csytrs_3 (uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
 CSYTRS_3
subroutine csytrs_aa (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
 CSYTRS_AA
subroutine csytrs_aa_2stage (uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
 CSYTRS_AA_2STAGE
subroutine csytrs_rook (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 CSYTRS_ROOK
subroutine ctgsyl (trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
 CTGSYL
subroutine ctrsyl (trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
 CTRSYL

Detailed Description

This is the group of complex computational functions for SY matrices

Function Documentation

◆ chesv_aa_2stage()

subroutine chesv_aa_2stage ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
integer lwork,
integer info )

CHESV_AA_2STAGE computes the solution to system of linear equations A * X = B for HE matrices

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

Purpose:
!>
!> CHESV_AA_2STAGE computes the solution to a complex system of 
!> linear equations
!>    A * X = B,
!> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!> matrices.
!>
!> Aasen's 2-stage algorithm is used to factor A as
!>    A = U**H * T * U,  if UPLO = 'U', or
!>    A = L * T * L**H,  if UPLO = 'L',
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is Hermitian and band. The matrix T is
!> then LU-factored with partial pivoting. The factored form of A
!> is then used to solve the system of equations A * X = B.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the hermitian matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, L is stored below (or above) the subdiaonal blocks,
!>          when UPLO  is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX array, dimension (LTB)
!>          On exit, details of the LU factorization of the band matrix.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N, internally
!>          used to select NB such that LTB >= (3*NB+1)*N.
!>
!>          If LTB = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of LTB, 
!>          returns this value as the first entry of TB, and
!>          no error message related to LTB is issued by XERBLA.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of T were interchanged with the
!>          row and column IPIV(k).
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX workspace of size LWORK
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The size of WORK. LWORK >= N, internally used to select NB
!>          such that LWORK >= N*NB.
!>
!>          If LWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the WORK array,
!>          returns this value as the first entry of the WORK array, and
!>          no error message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, band LU factorization failed on i-th column
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 183 of file chesv_aa_2stage.f.

186*
187* -- LAPACK computational routine --
188* -- LAPACK is a software package provided by Univ. of Tennessee, --
189* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
190*
191 IMPLICIT NONE
192*
193* .. Scalar Arguments ..
194 CHARACTER UPLO
195 INTEGER N, NRHS, LDA, LDB, LTB, LWORK, INFO
196* ..
197* .. Array Arguments ..
198 INTEGER IPIV( * ), IPIV2( * )
199 COMPLEX A( LDA, * ), B( LDB, * ), TB( * ), WORK( * )
200* ..
201*
202* =====================================================================
203*
204* .. Local Scalars ..
205 LOGICAL UPPER, TQUERY, WQUERY
206 INTEGER LWKOPT
207* ..
208* .. External Functions ..
209 LOGICAL LSAME
210 EXTERNAL lsame
211* ..
212* .. External Subroutines ..
213 EXTERNAL chetrf_aa_2stage, chetrs_aa_2stage,
214 $ xerbla
215* ..
216* .. Intrinsic Functions ..
217 INTRINSIC max
218* ..
219* .. Executable Statements ..
220*
221* Test the input parameters.
222*
223 info = 0
224 upper = lsame( uplo, 'U' )
225 wquery = ( lwork.EQ.-1 )
226 tquery = ( ltb.EQ.-1 )
227 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
228 info = -1
229 ELSE IF( n.LT.0 ) THEN
230 info = -2
231 ELSE IF( nrhs.LT.0 ) THEN
232 info = -3
233 ELSE IF( lda.LT.max( 1, n ) ) THEN
234 info = -5
235 ELSE IF( ltb.LT.( 4*n ) .AND. .NOT.tquery ) THEN
236 info = -7
237 ELSE IF( ldb.LT.max( 1, n ) ) THEN
238 info = -11
239 ELSE IF( lwork.LT.n .AND. .NOT.wquery ) THEN
240 info = -13
241 END IF
242*
243 IF( info.EQ.0 ) THEN
244 CALL chetrf_aa_2stage( uplo, n, a, lda, tb, -1, ipiv,
245 $ ipiv2, work, -1, info )
246 lwkopt = int( work(1) )
247 END IF
248*
249 IF( info.NE.0 ) THEN
250 CALL xerbla( 'CHESV_AA_2STAGE', -info )
251 RETURN
252 ELSE IF( wquery .OR. tquery ) THEN
253 RETURN
254 END IF
255*
256*
257* Compute the factorization A = U**H*T*U or A = L*T*L**H.
258*
259 CALL chetrf_aa_2stage( uplo, n, a, lda, tb, ltb, ipiv, ipiv2,
260 $ work, lwork, info )
261 IF( info.EQ.0 ) THEN
262*
263* Solve the system A*X = B, overwriting B with X.
264*
265 CALL chetrs_aa_2stage( uplo, n, nrhs, a, lda, tb, ltb, ipiv,
266 $ ipiv2, b, ldb, info )
267*
268 END IF
269*
270 work( 1 ) = lwkopt
271*
272 RETURN
273*
274* End of CHESV_AA_2STAGE
275*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
chetrs_aa_2stage
subroutine chetrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
CHETRS_AA_2STAGE
Definition chetrs_aa_2stage.f:141
chetrf_aa_2stage
subroutine chetrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
CHETRF_AA_2STAGE
Definition chetrf_aa_2stage.f:160
max
#define max(a, b)
Definition macros.h:21

◆ chetrf_aa_2stage()

subroutine chetrf_aa_2stage ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex, dimension( * ) work,
integer lwork,
integer info )

CHETRF_AA_2STAGE

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

Purpose:
!>
!> CHETRF_AA_2STAGE computes the factorization of a real hermitian matrix A
!> using the Aasen's algorithm.  The form of the factorization is
!>
!>    A = U**T*T*U  or  A = L*T*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is a hermitian band matrix with the
!> bandwidth of NB (NB is internally selected and stored in TB( 1 ), and T is 
!> LU factorized with partial pivoting).
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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 COMPLEX array, dimension (LDA,N)
!>          On entry, the hermitian matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, L is stored below (or above) the subdiaonal blocks,
!>          when UPLO  is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX array, dimension (LTB)
!>          On exit, details of the LU factorization of the band matrix.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N, internally
!>          used to select NB such that LTB >= (3*NB+1)*N.
!>
!>          If LTB = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of LTB, 
!>          returns this value as the first entry of TB, and
!>          no error message related to LTB is issued by XERBLA.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of T were interchanged with the
!>          row and column IPIV(k).
!>
[out]WORK
!>          WORK is COMPLEX workspace of size LWORK
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The size of WORK. LWORK >= N, internally used to select NB
!>          such that LWORK >= N*NB.
!>
!>          If LWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the WORK array,
!>          returns this value as the first entry of the WORK array, and
!>          no error message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, band LU factorization failed on i-th column
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 158 of file chetrf_aa_2stage.f.

160*
161* -- LAPACK computational routine --
162* -- LAPACK is a software package provided by Univ. of Tennessee, --
163* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
164*
165 IMPLICIT NONE
166*
167* .. Scalar Arguments ..
168 CHARACTER UPLO
169 INTEGER N, LDA, LTB, LWORK, INFO
170* ..
171* .. Array Arguments ..
172 INTEGER IPIV( * ), IPIV2( * )
173 COMPLEX A( LDA, * ), TB( * ), WORK( * )
174* ..
175*
176* =====================================================================
177* .. Parameters ..
178 COMPLEX ZERO, ONE
179 parameter( zero = ( 0.0e+0, 0.0e+0 ),
180 $ one = ( 1.0e+0, 0.0e+0 ) )
181*
182* .. Local Scalars ..
183 LOGICAL UPPER, TQUERY, WQUERY
184 INTEGER I, J, K, I1, I2, TD
185 INTEGER LDTB, NB, KB, JB, NT, IINFO
186 COMPLEX PIV
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 INTEGER ILAENV
191 EXTERNAL lsame, ilaenv
192
193* ..
194* .. External Subroutines ..
195 EXTERNAL xerbla, ccopy, clacgv, clacpy,
196 $ claset, cgbtrf, cgemm, cgetrf,
197 $ chegst, cswap, ctrsm
198* ..
199* .. Intrinsic Functions ..
200 INTRINSIC conjg, min, max
201* ..
202* .. Executable Statements ..
203*
204* Test the input parameters.
205*
206 info = 0
207 upper = lsame( uplo, 'U' )
208 wquery = ( lwork.EQ.-1 )
209 tquery = ( ltb.EQ.-1 )
210 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
211 info = -1
212 ELSE IF( n.LT.0 ) THEN
213 info = -2
214 ELSE IF( lda.LT.max( 1, n ) ) THEN
215 info = -4
216 ELSE IF ( ltb .LT. 4*n .AND. .NOT.tquery ) THEN
217 info = -6
218 ELSE IF ( lwork .LT. n .AND. .NOT.wquery ) THEN
219 info = -10
220 END IF
221*
222 IF( info.NE.0 ) THEN
223 CALL xerbla( 'CHETRF_AA_2STAGE', -info )
224 RETURN
225 END IF
226*
227* Answer the query
228*
229 nb = ilaenv( 1, 'CHETRF_AA_2STAGE', uplo, n, -1, -1, -1 )
230 IF( info.EQ.0 ) THEN
231 IF( tquery ) THEN
232 tb( 1 ) = (3*nb+1)*n
233 END IF
234 IF( wquery ) THEN
235 work( 1 ) = n*nb
236 END IF
237 END IF
238 IF( tquery .OR. wquery ) THEN
239 RETURN
240 END IF
241*
242* Quick return
243*
244 IF ( n.EQ.0 ) THEN
245 RETURN
246 ENDIF
247*
248* Determine the number of the block size
249*
250 ldtb = ltb/n
251 IF( ldtb .LT. 3*nb+1 ) THEN
252 nb = (ldtb-1)/3
253 END IF
254 IF( lwork .LT. nb*n ) THEN
255 nb = lwork/n
256 END IF
257*
258* Determine the number of the block columns
259*
260 nt = (n+nb-1)/nb
261 td = 2*nb
262 kb = min(nb, n)
263*
264* Initialize vectors/matrices
265*
266 DO j = 1, kb
267 ipiv( j ) = j
268 END DO
269*
270* Save NB
271*
272 tb( 1 ) = nb
273*
274 IF( upper ) THEN
275*
276* .....................................................
277* Factorize A as U**T*D*U using the upper triangle of A
278* .....................................................
279*
280 DO j = 0, nt-1
281*
282* Generate Jth column of W and H
283*
284 kb = min(nb, n-j*nb)
285 DO i = 1, j-1
286 IF( i.EQ.1 ) THEN
287* H(I,J) = T(I,I)*U(I,J) + T(I+1,I)*U(I+1,J)
288 IF( i .EQ. (j-1) ) THEN
289 jb = nb+kb
290 ELSE
291 jb = 2*nb
292 END IF
293 CALL cgemm( 'NoTranspose', 'NoTranspose',
294 $ nb, kb, jb,
295 $ one, tb( td+1 + (i*nb)*ldtb ), ldtb-1,
296 $ a( (i-1)*nb+1, j*nb+1 ), lda,
297 $ zero, work( i*nb+1 ), n )
298 ELSE
299* H(I,J) = T(I,I-1)*U(I-1,J) + T(I,I)*U(I,J) + T(I,I+1)*U(I+1,J)
300 IF( i .EQ. (j-1) ) THEN
301 jb = 2*nb+kb
302 ELSE
303 jb = 3*nb
304 END IF
305 CALL cgemm( 'NoTranspose', 'NoTranspose',
306 $ nb, kb, jb,
307 $ one, tb( td+nb+1 + ((i-1)*nb)*ldtb ),
308 $ ldtb-1,
309 $ a( (i-2)*nb+1, j*nb+1 ), lda,
310 $ zero, work( i*nb+1 ), n )
311 END IF
312 END DO
313*
314* Compute T(J,J)
315*
316 CALL clacpy( 'Upper', kb, kb, a( j*nb+1, j*nb+1 ), lda,
317 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
318 IF( j.GT.1 ) THEN
319* T(J,J) = U(1:J,J)'*H(1:J)
320 CALL cgemm( 'Conjugate transpose', 'NoTranspose',
321 $ kb, kb, (j-1)*nb,
322 $ -one, a( 1, j*nb+1 ), lda,
323 $ work( nb+1 ), n,
324 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
325* T(J,J) += U(J,J)'*T(J,J-1)*U(J-1,J)
326 CALL cgemm( 'Conjugate transpose', 'NoTranspose',
327 $ kb, nb, kb,
328 $ one, a( (j-1)*nb+1, j*nb+1 ), lda,
329 $ tb( td+nb+1 + ((j-1)*nb)*ldtb ), ldtb-1,
330 $ zero, work( 1 ), n )
331 CALL cgemm( 'NoTranspose', 'NoTranspose',
332 $ kb, kb, nb,
333 $ -one, work( 1 ), n,
334 $ a( (j-2)*nb+1, j*nb+1 ), lda,
335 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
336 END IF
337 IF( j.GT.0 ) THEN
338 CALL chegst( 1, 'Upper', kb,
339 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1,
340 $ a( (j-1)*nb+1, j*nb+1 ), lda, iinfo )
341 END IF
342*
343* Expand T(J,J) into full format
344*
345 DO i = 1, kb
346 tb( td+1 + (j*nb+i-1)*ldtb )
347 $ = real( tb( td+1 + (j*nb+i-1)*ldtb ) )
348 DO k = i+1, kb
349 tb( td+(k-i)+1 + (j*nb+i-1)*ldtb )
350 $ = conjg( tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb ) )
351 END DO
352 END DO
353*
354 IF( j.LT.nt-1 ) THEN
355 IF( j.GT.0 ) THEN
356*
357* Compute H(J,J)
358*
359 IF( j.EQ.1 ) THEN
360 CALL cgemm( 'NoTranspose', 'NoTranspose',
361 $ kb, kb, kb,
362 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1,
363 $ a( (j-1)*nb+1, j*nb+1 ), lda,
364 $ zero, work( j*nb+1 ), n )
365 ELSE
366 CALL cgemm( 'NoTranspose', 'NoTranspose',
367 $ kb, kb, nb+kb,
368 $ one, tb( td+nb+1 + ((j-1)*nb)*ldtb ),
369 $ ldtb-1,
370 $ a( (j-2)*nb+1, j*nb+1 ), lda,
371 $ zero, work( j*nb+1 ), n )
372 END IF
373*
374* Update with the previous column
375*
376 CALL cgemm( 'Conjugate transpose', 'NoTranspose',
377 $ nb, n-(j+1)*nb, j*nb,
378 $ -one, work( nb+1 ), n,
379 $ a( 1, (j+1)*nb+1 ), lda,
380 $ one, a( j*nb+1, (j+1)*nb+1 ), lda )
381 END IF
382*
383* Copy panel to workspace to call CGETRF
384*
385 DO k = 1, nb
386 CALL ccopy( n-(j+1)*nb,
387 $ a( j*nb+k, (j+1)*nb+1 ), lda,
388 $ work( 1+(k-1)*n ), 1 )
389 END DO
390*
391* Factorize panel
392*
393 CALL cgetrf( n-(j+1)*nb, nb,
394 $ work, n,
395 $ ipiv( (j+1)*nb+1 ), iinfo )
396c IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN
397c INFO = IINFO+(J+1)*NB
398c END IF
399*
400* Copy panel back
401*
402 DO k = 1, nb
403*
404* Copy only L-factor
405*
406 CALL ccopy( n-k-(j+1)*nb,
407 $ work( k+1+(k-1)*n ), 1,
408 $ a( j*nb+k, (j+1)*nb+k+1 ), lda )
409*
410* Transpose U-factor to be copied back into T(J+1, J)
411*
412 CALL clacgv( k, work( 1+(k-1)*n ), 1 )
413 END DO
414*
415* Compute T(J+1, J), zero out for GEMM update
416*
417 kb = min(nb, n-(j+1)*nb)
418 CALL claset( 'Full', kb, nb, zero, zero,
419 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
420 CALL clacpy( 'Upper', kb, nb,
421 $ work, n,
422 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
423 IF( j.GT.0 ) THEN
424 CALL ctrsm( 'R', 'U', 'N', 'U', kb, nb, one,
425 $ a( (j-1)*nb+1, j*nb+1 ), lda,
426 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
427 END IF
428*
429* Copy T(J,J+1) into T(J+1, J), both upper/lower for GEMM
430* updates
431*
432 DO k = 1, nb
433 DO i = 1, kb
434 tb( td-nb+k-i+1 + (j*nb+nb+i-1)*ldtb )
435 $ = conjg( tb( td+nb+i-k+1 + (j*nb+k-1)*ldtb ) )
436 END DO
437 END DO
438 CALL claset( 'Lower', kb, nb, zero, one,
439 $ a( j*nb+1, (j+1)*nb+1), lda )
440*
441* Apply pivots to trailing submatrix of A
442*
443 DO k = 1, kb
444* > Adjust ipiv
445 ipiv( (j+1)*nb+k ) = ipiv( (j+1)*nb+k ) + (j+1)*nb
446*
447 i1 = (j+1)*nb+k
448 i2 = ipiv( (j+1)*nb+k )
449 IF( i1.NE.i2 ) THEN
450* > Apply pivots to previous columns of L
451 CALL cswap( k-1, a( (j+1)*nb+1, i1 ), 1,
452 $ a( (j+1)*nb+1, i2 ), 1 )
453* > Swap A(I1+1:M, I1) with A(I2, I1+1:M)
454 IF( i2.GT.(i1+1) ) THEN
455 CALL cswap( i2-i1-1, a( i1, i1+1 ), lda,
456 $ a( i1+1, i2 ), 1 )
457 CALL clacgv( i2-i1-1, a( i1+1, i2 ), 1 )
458 END IF
459 CALL clacgv( i2-i1, a( i1, i1+1 ), lda )
460* > Swap A(I2+1:M, I1) with A(I2+1:M, I2)
461 IF( i2.LT.n )
462 $ CALL cswap( n-i2, a( i1, i2+1 ), lda,
463 $ a( i2, i2+1 ), lda )
464* > Swap A(I1, I1) with A(I2, I2)
465 piv = a( i1, i1 )
466 a( i1, i1 ) = a( i2, i2 )
467 a( i2, i2 ) = piv
468* > Apply pivots to previous columns of L
469 IF( j.GT.0 ) THEN
470 CALL cswap( j*nb, a( 1, i1 ), 1,
471 $ a( 1, i2 ), 1 )
472 END IF
473 ENDIF
474 END DO
475 END IF
476 END DO
477 ELSE
478*
479* .....................................................
480* Factorize A as L*D*L**T using the lower triangle of A
481* .....................................................
482*
483 DO j = 0, nt-1
484*
485* Generate Jth column of W and H
486*
487 kb = min(nb, n-j*nb)
488 DO i = 1, j-1
489 IF( i.EQ.1 ) THEN
490* H(I,J) = T(I,I)*L(J,I)' + T(I+1,I)'*L(J,I+1)'
491 IF( i .EQ. (j-1) ) THEN
492 jb = nb+kb
493 ELSE
494 jb = 2*nb
495 END IF
496 CALL cgemm( 'NoTranspose', 'Conjugate transpose',
497 $ nb, kb, jb,
498 $ one, tb( td+1 + (i*nb)*ldtb ), ldtb-1,
499 $ a( j*nb+1, (i-1)*nb+1 ), lda,
500 $ zero, work( i*nb+1 ), n )
501 ELSE
502* H(I,J) = T(I,I-1)*L(J,I-1)' + T(I,I)*L(J,I)' + T(I,I+1)*L(J,I+1)'
503 IF( i .EQ. (j-1) ) THEN
504 jb = 2*nb+kb
505 ELSE
506 jb = 3*nb
507 END IF
508 CALL cgemm( 'NoTranspose', 'Conjugate transpose',
509 $ nb, kb, jb,
510 $ one, tb( td+nb+1 + ((i-1)*nb)*ldtb ),
511 $ ldtb-1,
512 $ a( j*nb+1, (i-2)*nb+1 ), lda,
513 $ zero, work( i*nb+1 ), n )
514 END IF
515 END DO
516*
517* Compute T(J,J)
518*
519 CALL clacpy( 'Lower', kb, kb, a( j*nb+1, j*nb+1 ), lda,
520 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
521 IF( j.GT.1 ) THEN
522* T(J,J) = L(J,1:J)*H(1:J)
523 CALL cgemm( 'NoTranspose', 'NoTranspose',
524 $ kb, kb, (j-1)*nb,
525 $ -one, a( j*nb+1, 1 ), lda,
526 $ work( nb+1 ), n,
527 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
528* T(J,J) += L(J,J)*T(J,J-1)*L(J,J-1)'
529 CALL cgemm( 'NoTranspose', 'NoTranspose',
530 $ kb, nb, kb,
531 $ one, a( j*nb+1, (j-1)*nb+1 ), lda,
532 $ tb( td+nb+1 + ((j-1)*nb)*ldtb ), ldtb-1,
533 $ zero, work( 1 ), n )
534 CALL cgemm( 'NoTranspose', 'Conjugate transpose',
535 $ kb, kb, nb,
536 $ -one, work( 1 ), n,
537 $ a( j*nb+1, (j-2)*nb+1 ), lda,
538 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
539 END IF
540 IF( j.GT.0 ) THEN
541 CALL chegst( 1, 'Lower', kb,
542 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1,
543 $ a( j*nb+1, (j-1)*nb+1 ), lda, iinfo )
544 END IF
545*
546* Expand T(J,J) into full format
547*
548 DO i = 1, kb
549 tb( td+1 + (j*nb+i-1)*ldtb )
550 $ = real( tb( td+1 + (j*nb+i-1)*ldtb ) )
551 DO k = i+1, kb
552 tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb )
553 $ = conjg( tb( td+(k-i)+1 + (j*nb+i-1)*ldtb ) )
554 END DO
555 END DO
556*
557 IF( j.LT.nt-1 ) THEN
558 IF( j.GT.0 ) THEN
559*
560* Compute H(J,J)
561*
562 IF( j.EQ.1 ) THEN
563 CALL cgemm( 'NoTranspose', 'Conjugate transpose',
564 $ kb, kb, kb,
565 $ one, tb( td+1 + (j*nb)*ldtb ), ldtb-1,
566 $ a( j*nb+1, (j-1)*nb+1 ), lda,
567 $ zero, work( j*nb+1 ), n )
568 ELSE
569 CALL cgemm( 'NoTranspose', 'Conjugate transpose',
570 $ kb, kb, nb+kb,
571 $ one, tb( td+nb+1 + ((j-1)*nb)*ldtb ),
572 $ ldtb-1,
573 $ a( j*nb+1, (j-2)*nb+1 ), lda,
574 $ zero, work( j*nb+1 ), n )
575 END IF
576*
577* Update with the previous column
578*
579 CALL cgemm( 'NoTranspose', 'NoTranspose',
580 $ n-(j+1)*nb, nb, j*nb,
581 $ -one, a( (j+1)*nb+1, 1 ), lda,
582 $ work( nb+1 ), n,
583 $ one, a( (j+1)*nb+1, j*nb+1 ), lda )
584 END IF
585*
586* Factorize panel
587*
588 CALL cgetrf( n-(j+1)*nb, nb,
589 $ a( (j+1)*nb+1, j*nb+1 ), lda,
590 $ ipiv( (j+1)*nb+1 ), iinfo )
591c IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN
592c INFO = IINFO+(J+1)*NB
593c END IF
594*
595* Compute T(J+1, J), zero out for GEMM update
596*
597 kb = min(nb, n-(j+1)*nb)
598 CALL claset( 'Full', kb, nb, zero, zero,
599 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
600 CALL clacpy( 'Upper', kb, nb,
601 $ a( (j+1)*nb+1, j*nb+1 ), lda,
602 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
603 IF( j.GT.0 ) THEN
604 CALL ctrsm( 'R', 'L', 'C', 'U', kb, nb, one,
605 $ a( j*nb+1, (j-1)*nb+1 ), lda,
606 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
607 END IF
608*
609* Copy T(J+1,J) into T(J, J+1), both upper/lower for GEMM
610* updates
611*
612 DO k = 1, nb
613 DO i = 1, kb
614 tb( td-nb+k-i+1 + (j*nb+nb+i-1)*ldtb )
615 $ = conjg( tb( td+nb+i-k+1 + (j*nb+k-1)*ldtb ) )
616 END DO
617 END DO
618 CALL claset( 'Upper', kb, nb, zero, one,
619 $ a( (j+1)*nb+1, j*nb+1), lda )
620*
621* Apply pivots to trailing submatrix of A
622*
623 DO k = 1, kb
624* > Adjust ipiv
625 ipiv( (j+1)*nb+k ) = ipiv( (j+1)*nb+k ) + (j+1)*nb
626*
627 i1 = (j+1)*nb+k
628 i2 = ipiv( (j+1)*nb+k )
629 IF( i1.NE.i2 ) THEN
630* > Apply pivots to previous columns of L
631 CALL cswap( k-1, a( i1, (j+1)*nb+1 ), lda,
632 $ a( i2, (j+1)*nb+1 ), lda )
633* > Swap A(I1+1:M, I1) with A(I2, I1+1:M)
634 IF( i2.GT.(i1+1) ) THEN
635 CALL cswap( i2-i1-1, a( i1+1, i1 ), 1,
636 $ a( i2, i1+1 ), lda )
637 CALL clacgv( i2-i1-1, a( i2, i1+1 ), lda )
638 END IF
639 CALL clacgv( i2-i1, a( i1+1, i1 ), 1 )
640* > Swap A(I2+1:M, I1) with A(I2+1:M, I2)
641 IF( i2.LT.n )
642 $ CALL cswap( n-i2, a( i2+1, i1 ), 1,
643 $ a( i2+1, i2 ), 1 )
644* > Swap A(I1, I1) with A(I2, I2)
645 piv = a( i1, i1 )
646 a( i1, i1 ) = a( i2, i2 )
647 a( i2, i2 ) = piv
648* > Apply pivots to previous columns of L
649 IF( j.GT.0 ) THEN
650 CALL cswap( j*nb, a( i1, 1 ), lda,
651 $ a( i2, 1 ), lda )
652 END IF
653 ENDIF
654 END DO
655*
656* Apply pivots to previous columns of L
657*
658c CALL CLASWP( J*NB, A( 1, 1 ), LDA,
659c $ (J+1)*NB+1, (J+1)*NB+KB, IPIV, 1 )
660 END IF
661 END DO
662 END IF
663*
664* Factor the band matrix
665 CALL cgbtrf( n, n, nb, nb, tb, ldtb, ipiv2, info )
666*
667 RETURN
668*
669* End of CHETRF_AA_2STAGE
670*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
cgbtrf
subroutine cgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
CGBTRF
Definition cgbtrf.f:144
cgetrf
subroutine cgetrf(m, n, a, lda, ipiv, info)
CGETRF
Definition cgetrf.f:108
chegst
subroutine chegst(itype, uplo, n, a, lda, b, ldb, info)
CHEGST
Definition chegst.f:128
clacpy
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
Definition clacpy.f:103
clacgv
subroutine clacgv(n, x, incx)
CLACGV conjugates a complex vector.
Definition clacgv.f:74
claset
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition claset.f:106
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
ctrsm
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187
min
#define min(a, b)
Definition macros.h:20

◆ chetrs_aa_2stage()

subroutine chetrs_aa_2stage ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex, dimension( ldb, * ) b,
integer ldb,
integer info )

CHETRS_AA_2STAGE

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

Purpose:
!>
!> CHETRS_AA_2STAGE solves a system of linear equations A*X = B with a real
!> hermitian matrix A using the factorization A = U**T*T*U or
!> A = L*T*L**T computed by CHETRF_AA_2STAGE.
!>
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**T*T*U;
!>          = 'L':  Lower triangular, form is A = L*T*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          Details of factors computed by CHETRF_AA_2STAGE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX array, dimension (LTB)
!>          Details of factors computed by CHETRF_AA_2STAGE.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          CHETRF_AA_2STAGE.
!>
[in]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          CHETRF_AA_2STAGE.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file chetrs_aa_2stage.f.

141*
142* -- LAPACK computational routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146 IMPLICIT NONE
147*
148* .. Scalar Arguments ..
149 CHARACTER UPLO
150 INTEGER N, NRHS, LDA, LTB, LDB, INFO
151* ..
152* .. Array Arguments ..
153 INTEGER IPIV( * ), IPIV2( * )
154 COMPLEX A( LDA, * ), TB( * ), B( LDB, * )
155* ..
156*
157* =====================================================================
158*
159 COMPLEX ONE
160 parameter( one = ( 1.0e+0, 0.0e+0 ) )
161* ..
162* .. Local Scalars ..
163 INTEGER LDTB, NB
164 LOGICAL UPPER
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 EXTERNAL lsame
169* ..
170* .. External Subroutines ..
171 EXTERNAL cgbtrs, claswp, ctrsm, xerbla
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC max
175* ..
176* .. Executable Statements ..
177*
178 info = 0
179 upper = lsame( uplo, 'U' )
180 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
181 info = -1
182 ELSE IF( n.LT.0 ) THEN
183 info = -2
184 ELSE IF( nrhs.LT.0 ) THEN
185 info = -3
186 ELSE IF( lda.LT.max( 1, n ) ) THEN
187 info = -5
188 ELSE IF( ltb.LT.( 4*n ) ) THEN
189 info = -7
190 ELSE IF( ldb.LT.max( 1, n ) ) THEN
191 info = -11
192 END IF
193 IF( info.NE.0 ) THEN
194 CALL xerbla( 'CHETRS_AA_2STAGE', -info )
195 RETURN
196 END IF
197*
198* Quick return if possible
199*
200 IF( n.EQ.0 .OR. nrhs.EQ.0 )
201 $ RETURN
202*
203* Read NB and compute LDTB
204*
205 nb = int( tb( 1 ) )
206 ldtb = ltb/n
207*
208 IF( upper ) THEN
209*
210* Solve A*X = B, where A = U**T*T*U.
211*
212 IF( n.GT.nb ) THEN
213*
214* Pivot, P**T * B -> B
215*
216 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
217*
218* Compute (U**T \ B) -> B [ (U**T \P**T * B) ]
219*
220 CALL ctrsm( 'L', 'U', 'C', 'U', n-nb, nrhs, one, a(1, nb+1),
221 $ lda, b(nb+1, 1), ldb)
222*
223 END IF
224*
225* Compute T \ B -> B [ T \ (U**T \P**T * B) ]
226*
227 CALL cgbtrs( 'N', n, nb, nb, nrhs, tb, ldtb, ipiv2, b, ldb,
228 $ info)
229 IF( n.GT.nb ) THEN
230*
231* Compute (U \ B) -> B [ U \ (T \ (U**T \P**T * B) ) ]
232*
233 CALL ctrsm( 'L', 'U', 'N', 'U', n-nb, nrhs, one, a(1, nb+1),
234 $ lda, b(nb+1, 1), ldb)
235*
236* Pivot, P * B [ P * (U \ (T \ (U**T \P**T * B) )) ]
237*
238 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
239*
240 END IF
241*
242 ELSE
243*
244* Solve A*X = B, where A = L*T*L**T.
245*
246 IF( n.GT.nb ) THEN
247*
248* Pivot, P**T * B
249*
250 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
251*
252* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
253*
254 CALL ctrsm( 'L', 'L', 'N', 'U', n-nb, nrhs, one, a(nb+1, 1),
255 $ lda, b(nb+1, 1), ldb)
256*
257 END IF
258*
259* Compute T \ B -> B [ T \ (L \P**T * B) ]
260*
261 CALL cgbtrs( 'N', n, nb, nb, nrhs, tb, ldtb, ipiv2, b, ldb,
262 $ info)
263 IF( n.GT.nb ) THEN
264*
265* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
266*
267 CALL ctrsm( 'L', 'L', 'C', 'U', n-nb, nrhs, one, a(nb+1, 1),
268 $ lda, b(nb+1, 1), ldb)
269*
270* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ]
271*
272 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
273*
274 END IF
275 END IF
276*
277 RETURN
278*
279* End of CHETRS_AA_2STAGE
280*
cgbtrs
subroutine cgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
CGBTRS
Definition cgbtrs.f:138
claswp
subroutine claswp(n, a, lda, k1, k2, ipiv, incx)
CLASWP performs a series of row interchanges on a general rectangular matrix.
Definition claswp.f:115

◆ cla_syamv()

subroutine cla_syamv ( integer uplo,
integer n,
real alpha,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) x,
integer incx,
real beta,
real, dimension( * ) y,
integer incy )

CLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds.

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

Purpose:
!>
!> CLA_SYAMV  performs the matrix-vector operation
!>
!>         y := alpha*abs(A)*abs(x) + beta*abs(y),
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> n by n symmetric matrix.
!>
!> This function is primarily used in calculating error bounds.
!> To protect against underflow during evaluation, components in
!> the resulting vector are perturbed away from zero by (N+1)
!> times the underflow threshold.  To prevent unnecessarily large
!> errors for block-structure embedded in general matrices,
!>  zero components are not perturbed.  A zero
!> entry is considered  if all multiplications involved
!> in computing that entry have at least one zero multiplicand.
!>
Parameters
[in]UPLO
!>          UPLO is INTEGER
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the array A is to be referenced as
!>           follows:
!>
!>              UPLO = BLAS_UPPER   Only the upper triangular part of A
!>                                  is to be referenced.
!>
!>              UPLO = BLAS_LOWER   Only the lower triangular part of A
!>                                  is to be referenced.
!>
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the number of columns of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is REAL .
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX array, dimension ( LDA, n ).
!>           Before entry, the leading m by n part of the array A must
!>           contain the matrix of coefficients.
!>           Unchanged on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the calling (sub) program. LDA must be at least
!>           max( 1, n ).
!>           Unchanged on exit.
!>
[in]X
!>          X is COMPLEX array, dimension
!>           ( 1 + ( n - 1 )*abs( INCX ) )
!>           Before entry, the incremented array X must contain the
!>           vector x.
!>           Unchanged on exit.
!>
[in]INCX
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is REAL .
!>           On entry, BETA specifies the scalar beta. When BETA is
!>           supplied as zero then Y need not be set on input.
!>           Unchanged on exit.
!>
[in,out]Y
!>          Y is REAL array, dimension
!>           ( 1 + ( n - 1 )*abs( INCY ) )
!>           Before entry with BETA non-zero, the incremented array Y
!>           must contain the vector y. On exit, Y is overwritten by the
!>           updated vector y.
!>
[in]INCY
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!>           Unchanged on exit.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Level 2 Blas routine.
!>
!>  -- Written on 22-October-1986.
!>     Jack Dongarra, Argonne National Lab.
!>     Jeremy Du Croz, Nag Central Office.
!>     Sven Hammarling, Nag Central Office.
!>     Richard Hanson, Sandia National Labs.
!>  -- Modified for the absolute-value product, April 2006
!>     Jason Riedy, UC Berkeley
!>

Definition at line 177 of file cla_syamv.f.

179*
180* -- LAPACK computational routine --
181* -- LAPACK is a software package provided by Univ. of Tennessee, --
182* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
183*
184* .. Scalar Arguments ..
185 REAL ALPHA, BETA
186 INTEGER INCX, INCY, LDA, N
187 INTEGER UPLO
188* ..
189* .. Array Arguments ..
190 COMPLEX A( LDA, * ), X( * )
191 REAL Y( * )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 REAL ONE, ZERO
198 parameter( one = 1.0e+0, zero = 0.0e+0 )
199* ..
200* .. Local Scalars ..
201 LOGICAL SYMB_ZERO
202 REAL TEMP, SAFE1
203 INTEGER I, INFO, IY, J, JX, KX, KY
204 COMPLEX ZDUM
205* ..
206* .. External Subroutines ..
207 EXTERNAL xerbla, slamch
208 REAL SLAMCH
209* ..
210* .. External Functions ..
211 EXTERNAL ilauplo
212 INTEGER ILAUPLO
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC max, abs, sign, real, aimag
216* ..
217* .. Statement Functions ..
218 REAL CABS1
219* ..
220* .. Statement Function Definitions ..
221 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
222* ..
223* .. Executable Statements ..
224*
225* Test the input parameters.
226*
227 info = 0
228 IF ( uplo.NE.ilauplo( 'U' ) .AND.
229 $ uplo.NE.ilauplo( 'L' ) )THEN
230 info = 1
231 ELSE IF( n.LT.0 )THEN
232 info = 2
233 ELSE IF( lda.LT.max( 1, n ) )THEN
234 info = 5
235 ELSE IF( incx.EQ.0 )THEN
236 info = 7
237 ELSE IF( incy.EQ.0 )THEN
238 info = 10
239 END IF
240 IF( info.NE.0 )THEN
241 CALL xerbla( 'CLA_SYAMV', info )
242 RETURN
243 END IF
244*
245* Quick return if possible.
246*
247 IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
248 $ RETURN
249*
250* Set up the start points in X and Y.
251*
252 IF( incx.GT.0 )THEN
253 kx = 1
254 ELSE
255 kx = 1 - ( n - 1 )*incx
256 END IF
257 IF( incy.GT.0 )THEN
258 ky = 1
259 ELSE
260 ky = 1 - ( n - 1 )*incy
261 END IF
262*
263* Set SAFE1 essentially to be the underflow threshold times the
264* number of additions in each row.
265*
266 safe1 = slamch( 'Safe minimum' )
267 safe1 = (n+1)*safe1
268*
269* Form y := alpha*abs(A)*abs(x) + beta*abs(y).
270*
271* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to
272* the inexact flag. Still doesn't help change the iteration order
273* to per-column.
274*
275 iy = ky
276 IF ( incx.EQ.1 ) THEN
277 IF ( uplo .EQ. ilauplo( 'U' ) ) THEN
278 DO i = 1, n
279 IF ( beta .EQ. zero ) THEN
280 symb_zero = .true.
281 y( iy ) = 0.0
282 ELSE IF ( y( iy ) .EQ. zero ) THEN
283 symb_zero = .true.
284 ELSE
285 symb_zero = .false.
286 y( iy ) = beta * abs( y( iy ) )
287 END IF
288 IF ( alpha .NE. zero ) THEN
289 DO j = 1, i
290 temp = cabs1( a( j, i ) )
291 symb_zero = symb_zero .AND.
292 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
293
294 y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
295 END DO
296 DO j = i+1, n
297 temp = cabs1( a( i, j ) )
298 symb_zero = symb_zero .AND.
299 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
300
301 y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
302 END DO
303 END IF
304
305 IF ( .NOT.symb_zero )
306 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
307
308 iy = iy + incy
309 END DO
310 ELSE
311 DO i = 1, n
312 IF ( beta .EQ. zero ) THEN
313 symb_zero = .true.
314 y( iy ) = 0.0
315 ELSE IF ( y( iy ) .EQ. zero ) THEN
316 symb_zero = .true.
317 ELSE
318 symb_zero = .false.
319 y( iy ) = beta * abs( y( iy ) )
320 END IF
321 IF ( alpha .NE. zero ) THEN
322 DO j = 1, i
323 temp = cabs1( a( i, j ) )
324 symb_zero = symb_zero .AND.
325 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
326
327 y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
328 END DO
329 DO j = i+1, n
330 temp = cabs1( a( j, i ) )
331 symb_zero = symb_zero .AND.
332 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
333
334 y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
335 END DO
336 END IF
337
338 IF ( .NOT.symb_zero )
339 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
340
341 iy = iy + incy
342 END DO
343 END IF
344 ELSE
345 IF ( uplo .EQ. ilauplo( 'U' ) ) THEN
346 DO i = 1, n
347 IF ( beta .EQ. zero ) THEN
348 symb_zero = .true.
349 y( iy ) = 0.0
350 ELSE IF ( y( iy ) .EQ. zero ) THEN
351 symb_zero = .true.
352 ELSE
353 symb_zero = .false.
354 y( iy ) = beta * abs( y( iy ) )
355 END IF
356 jx = kx
357 IF ( alpha .NE. zero ) THEN
358 DO j = 1, i
359 temp = cabs1( a( j, i ) )
360 symb_zero = symb_zero .AND.
361 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
362
363 y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
364 jx = jx + incx
365 END DO
366 DO j = i+1, n
367 temp = cabs1( a( i, j ) )
368 symb_zero = symb_zero .AND.
369 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
370
371 y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
372 jx = jx + incx
373 END DO
374 END IF
375
376 IF ( .NOT.symb_zero )
377 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
378
379 iy = iy + incy
380 END DO
381 ELSE
382 DO i = 1, n
383 IF ( beta .EQ. zero ) THEN
384 symb_zero = .true.
385 y( iy ) = 0.0
386 ELSE IF ( y( iy ) .EQ. zero ) THEN
387 symb_zero = .true.
388 ELSE
389 symb_zero = .false.
390 y( iy ) = beta * abs( y( iy ) )
391 END IF
392 jx = kx
393 IF ( alpha .NE. zero ) THEN
394 DO j = 1, i
395 temp = cabs1( a( i, j ) )
396 symb_zero = symb_zero .AND.
397 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
398
399 y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
400 jx = jx + incx
401 END DO
402 DO j = i+1, n
403 temp = cabs1( a( j, i ) )
404 symb_zero = symb_zero .AND.
405 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
406
407 y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
408 jx = jx + incx
409 END DO
410 END IF
411
412 IF ( .NOT.symb_zero )
413 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
414
415 iy = iy + incy
416 END DO
417 END IF
418
419 END IF
420*
421 RETURN
422*
423* End of CLA_SYAMV
424*
alpha
#define alpha
Definition eval.h:35
ilauplo
integer function ilauplo(uplo)
ILAUPLO
Definition ilauplo.f:58
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ cla_syrcond_c()

real function cla_syrcond_c ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
real, dimension( * ) c,
logical capply,
integer info,
complex, dimension( * ) work,
real, dimension( * ) rwork )

CLA_SYRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for symmetric indefinite matrices.

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

Purpose:
!>
!>    CLA_SYRCOND_C Computes the infinity norm condition number of
!>    op(A) * inv(diag(C)) where C is a REAL vector.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by CSYTRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     Details of the interchanges and the block structure of D
!>     as determined by CSYTRF.
!>
[in]C
!>          C is REAL array, dimension (N)
!>     The vector C in the formula op(A) * inv(diag(C)).
!>
[in]CAPPLY
!>          CAPPLY is LOGICAL
!>     If .TRUE. then access the vector C in the formula above.
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N).
!>     Workspace.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 136 of file cla_syrcond_c.f.

138*
139* -- LAPACK computational routine --
140* -- LAPACK is a software package provided by Univ. of Tennessee, --
141* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
142*
143* .. Scalar Arguments ..
144 CHARACTER UPLO
145 LOGICAL CAPPLY
146 INTEGER N, LDA, LDAF, INFO
147* ..
148* .. Array Arguments ..
149 INTEGER IPIV( * )
150 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
151 REAL C( * ), RWORK( * )
152* ..
153*
154* =====================================================================
155*
156* .. Local Scalars ..
157 INTEGER KASE
158 REAL AINVNM, ANORM, TMP
159 INTEGER I, J
160 LOGICAL UP, UPPER
161 COMPLEX ZDUM
162* ..
163* .. Local Arrays ..
164 INTEGER ISAVE( 3 )
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 EXTERNAL lsame
169* ..
170* .. External Subroutines ..
171 EXTERNAL clacn2, csytrs, xerbla
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC abs, max
175* ..
176* .. Statement Functions ..
177 REAL CABS1
178* ..
179* .. Statement Function Definitions ..
180 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
181* ..
182* .. Executable Statements ..
183*
184 cla_syrcond_c = 0.0e+0
185*
186 info = 0
187 upper = lsame( uplo, 'U' )
188 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
189 info = -1
190 ELSE IF( n.LT.0 ) THEN
191 info = -2
192 ELSE IF( lda.LT.max( 1, n ) ) THEN
193 info = -4
194 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
195 info = -6
196 END IF
197 IF( info.NE.0 ) THEN
198 CALL xerbla( 'CLA_SYRCOND_C', -info )
199 RETURN
200 END IF
201 up = .false.
202 IF ( lsame( uplo, 'U' ) ) up = .true.
203*
204* Compute norm of op(A)*op2(C).
205*
206 anorm = 0.0e+0
207 IF ( up ) THEN
208 DO i = 1, n
209 tmp = 0.0e+0
210 IF ( capply ) THEN
211 DO j = 1, i
212 tmp = tmp + cabs1( a( j, i ) ) / c( j )
213 END DO
214 DO j = i+1, n
215 tmp = tmp + cabs1( a( i, j ) ) / c( j )
216 END DO
217 ELSE
218 DO j = 1, i
219 tmp = tmp + cabs1( a( j, i ) )
220 END DO
221 DO j = i+1, n
222 tmp = tmp + cabs1( a( i, j ) )
223 END DO
224 END IF
225 rwork( i ) = tmp
226 anorm = max( anorm, tmp )
227 END DO
228 ELSE
229 DO i = 1, n
230 tmp = 0.0e+0
231 IF ( capply ) THEN
232 DO j = 1, i
233 tmp = tmp + cabs1( a( i, j ) ) / c( j )
234 END DO
235 DO j = i+1, n
236 tmp = tmp + cabs1( a( j, i ) ) / c( j )
237 END DO
238 ELSE
239 DO j = 1, i
240 tmp = tmp + cabs1( a( i, j ) )
241 END DO
242 DO j = i+1, n
243 tmp = tmp + cabs1( a( j, i ) )
244 END DO
245 END IF
246 rwork( i ) = tmp
247 anorm = max( anorm, tmp )
248 END DO
249 END IF
250*
251* Quick return if possible.
252*
253 IF( n.EQ.0 ) THEN
254 cla_syrcond_c = 1.0e+0
255 RETURN
256 ELSE IF( anorm .EQ. 0.0e+0 ) THEN
257 RETURN
258 END IF
259*
260* Estimate the norm of inv(op(A)).
261*
262 ainvnm = 0.0e+0
263*
264 kase = 0
265 10 CONTINUE
266 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
267 IF( kase.NE.0 ) THEN
268 IF( kase.EQ.2 ) THEN
269*
270* Multiply by R.
271*
272 DO i = 1, n
273 work( i ) = work( i ) * rwork( i )
274 END DO
275*
276 IF ( up ) THEN
277 CALL csytrs( 'U', n, 1, af, ldaf, ipiv,
278 $ work, n, info )
279 ELSE
280 CALL csytrs( 'L', n, 1, af, ldaf, ipiv,
281 $ work, n, info )
282 ENDIF
283*
284* Multiply by inv(C).
285*
286 IF ( capply ) THEN
287 DO i = 1, n
288 work( i ) = work( i ) * c( i )
289 END DO
290 END IF
291 ELSE
292*
293* Multiply by inv(C**T).
294*
295 IF ( capply ) THEN
296 DO i = 1, n
297 work( i ) = work( i ) * c( i )
298 END DO
299 END IF
300*
301 IF ( up ) THEN
302 CALL csytrs( 'U', n, 1, af, ldaf, ipiv,
303 $ work, n, info )
304 ELSE
305 CALL csytrs( 'L', n, 1, af, ldaf, ipiv,
306 $ work, n, info )
307 END IF
308*
309* Multiply by R.
310*
311 DO i = 1, n
312 work( i ) = work( i ) * rwork( i )
313 END DO
314 END IF
315 GO TO 10
316 END IF
317*
318* Compute the estimate of the reciprocal condition number.
319*
320 IF( ainvnm .NE. 0.0e+0 )
321 $ cla_syrcond_c = 1.0e+0 / ainvnm
322*
323 RETURN
324*
325* End of CLA_SYRCOND_C
326*
clacn2
subroutine clacn2(n, v, x, est, kase, isave)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition clacn2.f:133
csytrs
subroutine csytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CSYTRS
Definition csytrs.f:120
cla_syrcond_c
real function cla_syrcond_c(uplo, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
CLA_SYRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for symmetric indefin...
Definition cla_syrcond_c.f:138

◆ cla_syrcond_x()

real function cla_syrcond_x ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
complex, dimension( * ) x,
integer info,
complex, dimension( * ) work,
real, dimension( * ) rwork )

CLA_SYRCOND_X computes the infinity norm condition number of op(A)*diag(x) for symmetric indefinite matrices.

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

Purpose:
!>
!>    CLA_SYRCOND_X Computes the infinity norm condition number of
!>    op(A) * diag(X) where X is a COMPLEX vector.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by CSYTRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     Details of the interchanges and the block structure of D
!>     as determined by CSYTRF.
!>
[in]X
!>          X is COMPLEX array, dimension (N)
!>     The vector X in the formula op(A) * diag(X).
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N).
!>     Workspace.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file cla_syrcond_x.f.

131*
132* -- LAPACK computational routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER UPLO
138 INTEGER N, LDA, LDAF, INFO
139* ..
140* .. Array Arguments ..
141 INTEGER IPIV( * )
142 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
143 REAL RWORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Local Scalars ..
149 INTEGER KASE
150 REAL AINVNM, ANORM, TMP
151 INTEGER I, J
152 LOGICAL UP, UPPER
153 COMPLEX ZDUM
154* ..
155* .. Local Arrays ..
156 INTEGER ISAVE( 3 )
157* ..
158* .. External Functions ..
159 LOGICAL LSAME
160 EXTERNAL lsame
161* ..
162* .. External Subroutines ..
163 EXTERNAL clacn2, csytrs, xerbla
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC abs, max
167* ..
168* .. Statement Functions ..
169 REAL CABS1
170* ..
171* .. Statement Function Definitions ..
172 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
173* ..
174* .. Executable Statements ..
175*
176 cla_syrcond_x = 0.0e+0
177*
178 info = 0
179 upper = lsame( uplo, 'U' )
180 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
181 info = -1
182 ELSE IF ( n.LT.0 ) THEN
183 info = -2
184 ELSE IF( lda.LT.max( 1, n ) ) THEN
185 info = -4
186 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
187 info = -6
188 END IF
189 IF( info.NE.0 ) THEN
190 CALL xerbla( 'CLA_SYRCOND_X', -info )
191 RETURN
192 END IF
193 up = .false.
194 IF ( lsame( uplo, 'U' ) ) up = .true.
195*
196* Compute norm of op(A)*op2(C).
197*
198 anorm = 0.0
199 IF ( up ) THEN
200 DO i = 1, n
201 tmp = 0.0e+0
202 DO j = 1, i
203 tmp = tmp + cabs1( a( j, i ) * x( j ) )
204 END DO
205 DO j = i+1, n
206 tmp = tmp + cabs1( a( i, j ) * x( j ) )
207 END DO
208 rwork( i ) = tmp
209 anorm = max( anorm, tmp )
210 END DO
211 ELSE
212 DO i = 1, n
213 tmp = 0.0e+0
214 DO j = 1, i
215 tmp = tmp + cabs1( a( i, j ) * x( j ) )
216 END DO
217 DO j = i+1, n
218 tmp = tmp + cabs1( a( j, i ) * x( j ) )
219 END DO
220 rwork( i ) = tmp
221 anorm = max( anorm, tmp )
222 END DO
223 END IF
224*
225* Quick return if possible.
226*
227 IF( n.EQ.0 ) THEN
228 cla_syrcond_x = 1.0e+0
229 RETURN
230 ELSE IF( anorm .EQ. 0.0e+0 ) THEN
231 RETURN
232 END IF
233*
234* Estimate the norm of inv(op(A)).
235*
236 ainvnm = 0.0e+0
237*
238 kase = 0
239 10 CONTINUE
240 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
241 IF( kase.NE.0 ) THEN
242 IF( kase.EQ.2 ) THEN
243*
244* Multiply by R.
245*
246 DO i = 1, n
247 work( i ) = work( i ) * rwork( i )
248 END DO
249*
250 IF ( up ) THEN
251 CALL csytrs( 'U', n, 1, af, ldaf, ipiv,
252 $ work, n, info )
253 ELSE
254 CALL csytrs( 'L', n, 1, af, ldaf, ipiv,
255 $ work, n, info )
256 ENDIF
257*
258* Multiply by inv(X).
259*
260 DO i = 1, n
261 work( i ) = work( i ) / x( i )
262 END DO
263 ELSE
264*
265* Multiply by inv(X**T).
266*
267 DO i = 1, n
268 work( i ) = work( i ) / x( i )
269 END DO
270*
271 IF ( up ) THEN
272 CALL csytrs( 'U', n, 1, af, ldaf, ipiv,
273 $ work, n, info )
274 ELSE
275 CALL csytrs( 'L', n, 1, af, ldaf, ipiv,
276 $ work, n, info )
277 END IF
278*
279* Multiply by R.
280*
281 DO i = 1, n
282 work( i ) = work( i ) * rwork( i )
283 END DO
284 END IF
285 GO TO 10
286 END IF
287*
288* Compute the estimate of the reciprocal condition number.
289*
290 IF( ainvnm .NE. 0.0e+0 )
291 $ cla_syrcond_x = 1.0e+0 / ainvnm
292*
293 RETURN
294*
295* End of CLA_SYRCOND_X
296*
cla_syrcond_x
real function cla_syrcond_x(uplo, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
CLA_SYRCOND_X computes the infinity norm condition number of op(A)*diag(x) for symmetric indefinite m...
Definition cla_syrcond_x.f:131

◆ cla_syrfsx_extended()

subroutine cla_syrfsx_extended ( integer prec_type,
character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
logical colequ,
real, dimension( * ) c,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldy, * ) y,
integer ldy,
real, dimension( * ) berr_out,
integer n_norms,
real, dimension( nrhs, * ) err_bnds_norm,
real, dimension( nrhs, * ) err_bnds_comp,
complex, dimension( * ) res,
real, dimension( * ) ayb,
complex, dimension( * ) dy,
complex, dimension( * ) y_tail,
real rcond,
integer ithresh,
real rthresh,
real dz_ub,
logical ignore_cwise,
integer info )

CLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric indefinite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.

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

Purpose:
!>
!> CLA_SYRFSX_EXTENDED improves the computed solution to a system of
!> linear equations by performing extra-precise iterative refinement
!> and provides error bounds and backward error estimates for the solution.
!> This subroutine is called by CSYRFSX to perform iterative refinement.
!> In addition to normwise error bound, the code provides maximum
!> componentwise error bound if possible. See comments for ERR_BNDS_NORM
!> and ERR_BNDS_COMP for details of the error bounds. Note that this
!> subroutine is only responsible for setting the second fields of
!> ERR_BNDS_NORM and ERR_BNDS_COMP.
!>
Parameters
[in]PREC_TYPE
!>          PREC_TYPE is INTEGER
!>     Specifies the intermediate precision to be used in refinement.
!>     The value is defined by ILAPREC(P) where P is a CHARACTER and P
!>          = 'S':  Single
!>          = 'D':  Double
!>          = 'I':  Indigenous
!>          = 'X' or 'E':  Extra
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>     The number of right-hand-sides, i.e., the number of columns of the
!>     matrix B.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by CSYTRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     Details of the interchanges and the block structure of D
!>     as determined by CSYTRF.
!>
[in]COLEQU
!>          COLEQU is LOGICAL
!>     If .TRUE. then column equilibration was done to A before calling
!>     this routine. This is needed to compute the solution and error
!>     bounds correctly.
!>
[in]C
!>          C is REAL array, dimension (N)
!>     The column scale factors for A. If COLEQU = .FALSE., C
!>     is not accessed. If C is input, each element of C should be a power
!>     of the radix to ensure a reliable solution and error estimates.
!>     Scaling by powers of the radix does not cause rounding errors unless
!>     the result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>     The right-hand-side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>     The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]Y
!>          Y is COMPLEX array, dimension (LDY,NRHS)
!>     On entry, the solution matrix X, as computed by CSYTRS.
!>     On exit, the improved solution matrix Y.
!>
[in]LDY
!>          LDY is INTEGER
!>     The leading dimension of the array Y.  LDY >= max(1,N).
!>
[out]BERR_OUT
!>          BERR_OUT is REAL array, dimension (NRHS)
!>     On exit, BERR_OUT(j) contains the componentwise relative backward
!>     error for right-hand-side j from the formula
!>         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
!>     where abs(Z) is the componentwise absolute value of the matrix
!>     or vector Z. This is computed by CLA_LIN_BERR.
!>
[in]N_NORMS
!>          N_NORMS is INTEGER
!>     Determines which error bounds to return (see ERR_BNDS_NORM
!>     and ERR_BNDS_COMP).
!>     If N_NORMS >= 1 return normwise error bounds.
!>     If N_NORMS >= 2 return componentwise error bounds.
!>
[in,out]ERR_BNDS_NORM
!>          ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     This subroutine is only responsible for setting the second field
!>     above.
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in,out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     This subroutine is only responsible for setting the second field
!>     above.
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]RES
!>          RES is COMPLEX array, dimension (N)
!>     Workspace to hold the intermediate residual.
!>
[in]AYB
!>          AYB is REAL array, dimension (N)
!>     Workspace.
!>
[in]DY
!>          DY is COMPLEX array, dimension (N)
!>     Workspace to hold the intermediate solution.
!>
[in]Y_TAIL
!>          Y_TAIL is COMPLEX array, dimension (N)
!>     Workspace to hold the trailing bits of the intermediate solution.
!>
[in]RCOND
!>          RCOND is REAL
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[in]ITHRESH
!>          ITHRESH is INTEGER
!>     The maximum number of residual computations allowed for
!>     refinement. The default is 10. For 'aggressive' set to 100 to
!>     permit convergence using approximate factorizations or
!>     factorizations other than LU. If the factorization uses a
!>     technique other than Gaussian elimination, the guarantees in
!>     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.
!>
[in]RTHRESH
!>          RTHRESH is REAL
!>     Determines when to stop refinement if the error estimate stops
!>     decreasing. Refinement will stop when the next solution no longer
!>     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is
!>     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The
!>     default value is 0.5. For 'aggressive' set to 0.9 to permit
!>     convergence on extremely ill-conditioned matrices. See LAWN 165
!>     for more details.
!>
[in]DZ_UB
!>          DZ_UB is REAL
!>     Determines when to start considering componentwise convergence.
!>     Componentwise convergence is only considered after each component
!>     of the solution Y is stable, which we define as the relative
!>     change in each component being less than DZ_UB. The default value
!>     is 0.25, requiring the first bit to be stable. See LAWN 165 for
!>     more details.
!>
[in]IGNORE_CWISE
!>          IGNORE_CWISE is LOGICAL
!>     If .TRUE. then ignore componentwise convergence. Default value
!>     is .FALSE..
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>       < 0:  if INFO = -i, the ith argument to CLA_SYRFSX_EXTENDED had an illegal
!>             value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 388 of file cla_syrfsx_extended.f.

395*
396* -- LAPACK computational routine --
397* -- LAPACK is a software package provided by Univ. of Tennessee, --
398* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
399*
400* .. Scalar Arguments ..
401 INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE,
402 $ N_NORMS, ITHRESH
403 CHARACTER UPLO
404 LOGICAL COLEQU, IGNORE_CWISE
405 REAL RTHRESH, DZ_UB
406* ..
407* .. Array Arguments ..
408 INTEGER IPIV( * )
409 COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
410 $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * )
411 REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
412 $ ERR_BNDS_NORM( NRHS, * ),
413 $ ERR_BNDS_COMP( NRHS, * )
414* ..
415*
416* =====================================================================
417*
418* .. Local Scalars ..
419 INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
420 $ Y_PREC_STATE
421 REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
422 $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,
423 $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,
424 $ EPS, HUGEVAL, INCR_THRESH
425 LOGICAL INCR_PREC, UPPER
426 COMPLEX ZDUM
427* ..
428* .. Parameters ..
429 INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE,
430 $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL,
431 $ EXTRA_Y
432 parameter( unstable_state = 0, working_state = 1,
433 $ conv_state = 2, noprog_state = 3 )
434 parameter( base_residual = 0, extra_residual = 1,
435 $ extra_y = 2 )
436 INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I
437 INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I
438 INTEGER CMP_ERR_I, PIV_GROWTH_I
439 parameter( final_nrm_err_i = 1, final_cmp_err_i = 2,
440 $ berr_i = 3 )
441 parameter( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
442 parameter( cmp_rcond_i = 7, cmp_err_i = 8,
443 $ piv_growth_i = 9 )
444 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
445 $ LA_LINRX_CWISE_I
446 parameter( la_linrx_itref_i = 1,
447 $ la_linrx_ithresh_i = 2 )
448 parameter( la_linrx_cwise_i = 3 )
449 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
450 $ LA_LINRX_RCOND_I
451 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
452 parameter( la_linrx_rcond_i = 3 )
453* ..
454* .. External Functions ..
455 LOGICAL LSAME
456 EXTERNAL ilauplo
457 INTEGER ILAUPLO
458* ..
459* .. External Subroutines ..
460 EXTERNAL caxpy, ccopy, csytrs, csymv, blas_csymv_x,
461 $ blas_csymv2_x, cla_syamv, cla_wwaddw,
462 $ cla_lin_berr
463 REAL SLAMCH
464* ..
465* .. Intrinsic Functions ..
466 INTRINSIC abs, real, aimag, max, min
467* ..
468* .. Statement Functions ..
469 REAL CABS1
470* ..
471* .. Statement Function Definitions ..
472 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
473* ..
474* .. Executable Statements ..
475*
476 info = 0
477 upper = lsame( uplo, 'U' )
478 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
479 info = -2
480 ELSE IF( n.LT.0 ) THEN
481 info = -3
482 ELSE IF( nrhs.LT.0 ) THEN
483 info = -4
484 ELSE IF( lda.LT.max( 1, n ) ) THEN
485 info = -6
486 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
487 info = -8
488 ELSE IF( ldb.LT.max( 1, n ) ) THEN
489 info = -13
490 ELSE IF( ldy.LT.max( 1, n ) ) THEN
491 info = -15
492 END IF
493 IF( info.NE.0 ) THEN
494 CALL xerbla( 'CLA_SYRFSX_EXTENDED', -info )
495 RETURN
496 END IF
497 eps = slamch( 'Epsilon' )
498 hugeval = slamch( 'Overflow' )
499* Force HUGEVAL to Inf
500 hugeval = hugeval * hugeval
501* Using HUGEVAL may lead to spurious underflows.
502 incr_thresh = real( n ) * eps
503
504 IF ( lsame( uplo, 'L' ) ) THEN
505 uplo2 = ilauplo( 'L' )
506 ELSE
507 uplo2 = ilauplo( 'U' )
508 ENDIF
509
510 DO j = 1, nrhs
511 y_prec_state = extra_residual
512 IF ( y_prec_state .EQ. extra_y ) THEN
513 DO i = 1, n
514 y_tail( i ) = 0.0
515 END DO
516 END IF
517
518 dxrat = 0.0
519 dxratmax = 0.0
520 dzrat = 0.0
521 dzratmax = 0.0
522 final_dx_x = hugeval
523 final_dz_z = hugeval
524 prevnormdx = hugeval
525 prev_dz_z = hugeval
526 dz_z = hugeval
527 dx_x = hugeval
528
529 x_state = working_state
530 z_state = unstable_state
531 incr_prec = .false.
532
533 DO cnt = 1, ithresh
534*
535* Compute residual RES = B_s - op(A_s) * Y,
536* op(A) = A, A**T, or A**H depending on TRANS (and type).
537*
538 CALL ccopy( n, b( 1, j ), 1, res, 1 )
539 IF ( y_prec_state .EQ. base_residual ) THEN
540 CALL csymv( uplo, n, cmplx(-1.0), a, lda, y(1,j), 1,
541 $ cmplx(1.0), res, 1 )
542 ELSE IF ( y_prec_state .EQ. extra_residual ) THEN
543 CALL blas_csymv_x( uplo2, n, cmplx(-1.0), a, lda,
544 $ y( 1, j ), 1, cmplx(1.0), res, 1, prec_type )
545 ELSE
546 CALL blas_csymv2_x(uplo2, n, cmplx(-1.0), a, lda,
547 $ y(1, j), y_tail, 1, cmplx(1.0), res, 1, prec_type)
548 END IF
549
550! XXX: RES is no longer needed.
551 CALL ccopy( n, res, 1, dy, 1 )
552 CALL csytrs( uplo, n, 1, af, ldaf, ipiv, dy, n, info )
553*
554* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT.
555*
556 normx = 0.0
557 normy = 0.0
558 normdx = 0.0
559 dz_z = 0.0
560 ymin = hugeval
561
562 DO i = 1, n
563 yk = cabs1( y( i, j ) )
564 dyk = cabs1( dy( i ) )
565
566 IF ( yk .NE. 0.0 ) THEN
567 dz_z = max( dz_z, dyk / yk )
568 ELSE IF ( dyk .NE. 0.0 ) THEN
569 dz_z = hugeval
570 END IF
571
572 ymin = min( ymin, yk )
573
574 normy = max( normy, yk )
575
576 IF ( colequ ) THEN
577 normx = max( normx, yk * c( i ) )
578 normdx = max( normdx, dyk * c( i ) )
579 ELSE
580 normx = normy
581 normdx = max( normdx, dyk )
582 END IF
583 END DO
584
585 IF ( normx .NE. 0.0 ) THEN
586 dx_x = normdx / normx
587 ELSE IF ( normdx .EQ. 0.0 ) THEN
588 dx_x = 0.0
589 ELSE
590 dx_x = hugeval
591 END IF
592
593 dxrat = normdx / prevnormdx
594 dzrat = dz_z / prev_dz_z
595*
596* Check termination criteria.
597*
598 IF ( ymin*rcond .LT. incr_thresh*normy
599 $ .AND. y_prec_state .LT. extra_y )
600 $ incr_prec = .true.
601
602 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
603 $ x_state = working_state
604 IF ( x_state .EQ. working_state ) THEN
605 IF ( dx_x .LE. eps ) THEN
606 x_state = conv_state
607 ELSE IF ( dxrat .GT. rthresh ) THEN
608 IF ( y_prec_state .NE. extra_y ) THEN
609 incr_prec = .true.
610 ELSE
611 x_state = noprog_state
612 END IF
613 ELSE
614 IF (dxrat .GT. dxratmax) dxratmax = dxrat
615 END IF
616 IF ( x_state .GT. working_state ) final_dx_x = dx_x
617 END IF
618
619 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
620 $ z_state = working_state
621 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
622 $ z_state = working_state
623 IF ( z_state .EQ. working_state ) THEN
624 IF ( dz_z .LE. eps ) THEN
625 z_state = conv_state
626 ELSE IF ( dz_z .GT. dz_ub ) THEN
627 z_state = unstable_state
628 dzratmax = 0.0
629 final_dz_z = hugeval
630 ELSE IF ( dzrat .GT. rthresh ) THEN
631 IF ( y_prec_state .NE. extra_y ) THEN
632 incr_prec = .true.
633 ELSE
634 z_state = noprog_state
635 END IF
636 ELSE
637 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
638 END IF
639 IF ( z_state .GT. working_state ) final_dz_z = dz_z
640 END IF
641
642 IF ( x_state.NE.working_state.AND.
643 $ ( ignore_cwise.OR.z_state.NE.working_state ) )
644 $ GOTO 666
645
646 IF ( incr_prec ) THEN
647 incr_prec = .false.
648 y_prec_state = y_prec_state + 1
649 DO i = 1, n
650 y_tail( i ) = 0.0
651 END DO
652 END IF
653
654 prevnormdx = normdx
655 prev_dz_z = dz_z
656*
657* Update soluton.
658*
659 IF ( y_prec_state .LT. extra_y ) THEN
660 CALL caxpy( n, cmplx(1.0), dy, 1, y(1,j), 1 )
661 ELSE
662 CALL cla_wwaddw( n, y(1,j), y_tail, dy )
663 END IF
664
665 END DO
666* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT.
667 666 CONTINUE
668*
669* Set final_* when cnt hits ithresh.
670*
671 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
672 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
673*
674* Compute error bounds.
675*
676 IF ( n_norms .GE. 1 ) THEN
677 err_bnds_norm( j, la_linrx_err_i ) =
678 $ final_dx_x / (1 - dxratmax)
679 END IF
680 IF ( n_norms .GE. 2 ) THEN
681 err_bnds_comp( j, la_linrx_err_i ) =
682 $ final_dz_z / (1 - dzratmax)
683 END IF
684*
685* Compute componentwise relative backward error from formula
686* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
687* where abs(Z) is the componentwise absolute value of the matrix
688* or vector Z.
689*
690* Compute residual RES = B_s - op(A_s) * Y,
691* op(A) = A, A**T, or A**H depending on TRANS (and type).
692*
693 CALL ccopy( n, b( 1, j ), 1, res, 1 )
694 CALL csymv( uplo, n, cmplx(-1.0), a, lda, y(1,j), 1,
695 $ cmplx(1.0), res, 1 )
696
697 DO i = 1, n
698 ayb( i ) = cabs1( b( i, j ) )
699 END DO
700*
701* Compute abs(op(A_s))*abs(Y) + abs(B_s).
702*
703 CALL cla_syamv ( uplo2, n, 1.0,
704 $ a, lda, y(1, j), 1, 1.0, ayb, 1 )
705
706 CALL cla_lin_berr ( n, n, 1, res, ayb, berr_out( j ) )
707*
708* End of loop for each RHS.
709*
710 END DO
711*
712 RETURN
713*
714* End of CLA_SYRFSX_EXTENDED
715*
cmplx
float cmplx[2]
Definition pblas.h:136
cla_lin_berr
subroutine cla_lin_berr(n, nz, nrhs, res, ayb, berr)
CLA_LIN_BERR computes a component-wise relative backward error.
Definition cla_lin_berr.f:101
cla_wwaddw
subroutine cla_wwaddw(n, x, y, w)
CLA_WWADDW adds a vector into a doubled-single vector.
Definition cla_wwaddw.f:81
csymv
subroutine csymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
CSYMV computes a matrix-vector product for a complex symmetric matrix.
Definition csymv.f:157
cla_syamv
subroutine cla_syamv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
CLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bou...
Definition cla_syamv.f:179
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88

◆ cla_syrpvgrw()

real function cla_syrpvgrw ( character*1 uplo,
integer n,
integer info,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
real, dimension( * ) work )

CLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite matrix.

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

Purpose:
!>
!>
!> CLA_SYRPVGRW computes the reciprocal pivot growth factor
!> norm(A)/norm(U). The  norm is used. If this is
!> much less than 1, the stability of the LU factorization of the
!> (equilibrated) matrix A could be poor. This also means that the
!> solution X, estimated condition numbers, and error bounds could be
!> unreliable.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]INFO
!>          INFO is INTEGER
!>     The value of INFO returned from CSYTRF, .i.e., the pivot in
!>     column INFO is exactly 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by CSYTRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     Details of the interchanges and the block structure of D
!>     as determined by CSYTRF.
!>
[out]WORK
!>          WORK is REAL array, dimension (2*N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 121 of file cla_syrpvgrw.f.

123*
124* -- LAPACK computational routine --
125* -- LAPACK is a software package provided by Univ. of Tennessee, --
126* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
127*
128* .. Scalar Arguments ..
129 CHARACTER*1 UPLO
130 INTEGER N, INFO, LDA, LDAF
131* ..
132* .. Array Arguments ..
133 COMPLEX A( LDA, * ), AF( LDAF, * )
134 REAL WORK( * )
135 INTEGER IPIV( * )
136* ..
137*
138* =====================================================================
139*
140* .. Local Scalars ..
141 INTEGER NCOLS, I, J, K, KP
142 REAL AMAX, UMAX, RPVGRW, TMP
143 LOGICAL UPPER
144 COMPLEX ZDUM
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, real, aimag, max, min
148* ..
149* .. External Subroutines ..
150 EXTERNAL lsame
151 LOGICAL LSAME
152* ..
153* .. Statement Functions ..
154 REAL CABS1
155* ..
156* .. Statement Function Definitions ..
157 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
158* ..
159* .. Executable Statements ..
160*
161 upper = lsame( 'Upper', uplo )
162 IF ( info.EQ.0 ) THEN
163 IF ( upper ) THEN
164 ncols = 1
165 ELSE
166 ncols = n
167 END IF
168 ELSE
169 ncols = info
170 END IF
171
172 rpvgrw = 1.0
173 DO i = 1, 2*n
174 work( i ) = 0.0
175 END DO
176*
177* Find the max magnitude entry of each column of A. Compute the max
178* for all N columns so we can apply the pivot permutation while
179* looping below. Assume a full factorization is the common case.
180*
181 IF ( upper ) THEN
182 DO j = 1, n
183 DO i = 1, j
184 work( n+i ) = max( cabs1( a( i, j ) ), work( n+i ) )
185 work( n+j ) = max( cabs1( a( i, j ) ), work( n+j ) )
186 END DO
187 END DO
188 ELSE
189 DO j = 1, n
190 DO i = j, n
191 work( n+i ) = max( cabs1( a( i, j ) ), work( n+i ) )
192 work( n+j ) = max( cabs1( a( i, j ) ), work( n+j ) )
193 END DO
194 END DO
195 END IF
196*
197* Now find the max magnitude entry of each column of U or L. Also
198* permute the magnitudes of A above so they're in the same order as
199* the factor.
200*
201* The iteration orders and permutations were copied from csytrs.
202* Calls to SSWAP would be severe overkill.
203*
204 IF ( upper ) THEN
205 k = n
206 DO WHILE ( k .LT. ncols .AND. k.GT.0 )
207 IF ( ipiv( k ).GT.0 ) THEN
208! 1x1 pivot
209 kp = ipiv( k )
210 IF ( kp .NE. k ) THEN
211 tmp = work( n+k )
212 work( n+k ) = work( n+kp )
213 work( n+kp ) = tmp
214 END IF
215 DO i = 1, k
216 work( k ) = max( cabs1( af( i, k ) ), work( k ) )
217 END DO
218 k = k - 1
219 ELSE
220! 2x2 pivot
221 kp = -ipiv( k )
222 tmp = work( n+k-1 )
223 work( n+k-1 ) = work( n+kp )
224 work( n+kp ) = tmp
225 DO i = 1, k-1
226 work( k ) = max( cabs1( af( i, k ) ), work( k ) )
227 work( k-1 ) =
228 $ max( cabs1( af( i, k-1 ) ), work( k-1 ) )
229 END DO
230 work( k ) = max( cabs1( af( k, k ) ), work( k ) )
231 k = k - 2
232 END IF
233 END DO
234 k = ncols
235 DO WHILE ( k .LE. n )
236 IF ( ipiv( k ).GT.0 ) THEN
237 kp = ipiv( k )
238 IF ( kp .NE. k ) THEN
239 tmp = work( n+k )
240 work( n+k ) = work( n+kp )
241 work( n+kp ) = tmp
242 END IF
243 k = k + 1
244 ELSE
245 kp = -ipiv( k )
246 tmp = work( n+k )
247 work( n+k ) = work( n+kp )
248 work( n+kp ) = tmp
249 k = k + 2
250 END IF
251 END DO
252 ELSE
253 k = 1
254 DO WHILE ( k .LE. ncols )
255 IF ( ipiv( k ).GT.0 ) THEN
256! 1x1 pivot
257 kp = ipiv( k )
258 IF ( kp .NE. k ) THEN
259 tmp = work( n+k )
260 work( n+k ) = work( n+kp )
261 work( n+kp ) = tmp
262 END IF
263 DO i = k, n
264 work( k ) = max( cabs1( af( i, k ) ), work( k ) )
265 END DO
266 k = k + 1
267 ELSE
268! 2x2 pivot
269 kp = -ipiv( k )
270 tmp = work( n+k+1 )
271 work( n+k+1 ) = work( n+kp )
272 work( n+kp ) = tmp
273 DO i = k+1, n
274 work( k ) = max( cabs1( af( i, k ) ), work( k ) )
275 work( k+1 ) =
276 $ max( cabs1( af( i, k+1 ) ), work( k+1 ) )
277 END DO
278 work( k ) = max( cabs1( af( k, k ) ), work( k ) )
279 k = k + 2
280 END IF
281 END DO
282 k = ncols
283 DO WHILE ( k .GE. 1 )
284 IF ( ipiv( k ).GT.0 ) THEN
285 kp = ipiv( k )
286 IF ( kp .NE. k ) THEN
287 tmp = work( n+k )
288 work( n+k ) = work( n+kp )
289 work( n+kp ) = tmp
290 END IF
291 k = k - 1
292 ELSE
293 kp = -ipiv( k )
294 tmp = work( n+k )
295 work( n+k ) = work( n+kp )
296 work( n+kp ) = tmp
297 k = k - 2
298 ENDIF
299 END DO
300 END IF
301*
302* Compute the *inverse* of the max element growth factor. Dividing
303* by zero would imply the largest entry of the factor's column is
304* zero. Than can happen when either the column of A is zero or
305* massive pivots made the factor underflow to zero. Neither counts
306* as growth in itself, so simply ignore terms with zero
307* denominators.
308*
309 IF ( upper ) THEN
310 DO i = ncols, n
311 umax = work( i )
312 amax = work( n+i )
313 IF ( umax /= 0.0 ) THEN
314 rpvgrw = min( amax / umax, rpvgrw )
315 END IF
316 END DO
317 ELSE
318 DO i = 1, ncols
319 umax = work( i )
320 amax = work( n+i )
321 IF ( umax /= 0.0 ) THEN
322 rpvgrw = min( amax / umax, rpvgrw )
323 END IF
324 END DO
325 END IF
326
327 cla_syrpvgrw = rpvgrw
328*
329* End of CLA_SYRPVGRW
330*
cla_syrpvgrw
real function cla_syrpvgrw(uplo, n, info, a, lda, af, ldaf, ipiv, work)
CLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite m...
Definition cla_syrpvgrw.f:123

◆ clahef_aa()

subroutine clahef_aa ( character uplo,
integer j1,
integer m,
integer nb,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( * ) work )

CLAHEF_AA

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

Purpose:
!>
!> CLAHEF_AA factorizes a panel of a complex hermitian matrix A using
!> the Aasen's algorithm. The panel consists of a set of NB rows of A
!> when UPLO is U, or a set of NB columns when UPLO is L.
!>
!> In order to factorize the panel, the Aasen's algorithm requires the
!> last row, or column, of the previous panel. The first row, or column,
!> of A is set to be the first row, or column, of an identity matrix,
!> which is used to factorize the first panel.
!>
!> The resulting J-th row of U, or J-th column of L, is stored in the
!> (J-1)-th row, or column, of A (without the unit diagonals), while
!> the diagonal and subdiagonal of A are overwritten by those of T.
!>
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]J1
!>          J1 is INTEGER
!>          The location of the first row, or column, of the panel
!>          within the submatrix of A, passed to this routine, e.g.,
!>          when called by CHETRF_AA, for the first panel, J1 is 1,
!>          while for the remaining panels, J1 is 2.
!>
[in]M
!>          M is INTEGER
!>          The dimension of the submatrix. M >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The dimension of the panel to be facotorized.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,M) for
!>          the first panel, while dimension (LDA,M+1) for the
!>          remaining panels.
!>
!>          On entry, A contains the last row, or column, of
!>          the previous panel, and the trailing submatrix of A
!>          to be factorized, except for the first panel, only
!>          the panel is passed.
!>
!>          On exit, the leading panel is factorized.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the row and column interchanges,
!>          the row and column k were interchanged with the row and
!>          column IPIV(k).
!>
[in,out]H
!>          H is COMPLEX workspace, dimension (LDH,NB).
!>
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the workspace H. LDH >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX workspace, dimension (M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file clahef_aa.f.

144*
145* -- LAPACK computational routine --
146* -- LAPACK is a software package provided by Univ. of Tennessee, --
147* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
148*
149 IMPLICIT NONE
150*
151* .. Scalar Arguments ..
152 CHARACTER UPLO
153 INTEGER M, NB, J1, LDA, LDH
154* ..
155* .. Array Arguments ..
156 INTEGER IPIV( * )
157 COMPLEX A( LDA, * ), H( LDH, * ), WORK( * )
158* ..
159*
160* =====================================================================
161* .. Parameters ..
162 COMPLEX ZERO, ONE
163 parameter( zero = (0.0e+0, 0.0e+0), one = (1.0e+0, 0.0e+0) )
164*
165* .. Local Scalars ..
166 INTEGER J, K, K1, I1, I2, MJ
167 COMPLEX PIV, ALPHA
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER ICAMAX, ILAENV
172 EXTERNAL lsame, ilaenv, icamax
173* ..
174* .. External Subroutines ..
175 EXTERNAL clacgv, cgemv, cscal, caxpy, ccopy, cswap, claset,
176 $ xerbla
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC real, conjg, max
180* ..
181* .. Executable Statements ..
182*
183 j = 1
184*
185* K1 is the first column of the panel to be factorized
186* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks
187*
188 k1 = (2-j1)+1
189*
190 IF( lsame( uplo, 'U' ) ) THEN
191*
192* .....................................................
193* Factorize A as U**T*D*U using the upper triangle of A
194* .....................................................
195*
196 10 CONTINUE
197 IF ( j.GT.min(m, nb) )
198 $ GO TO 20
199*
200* K is the column to be factorized
201* when being called from CHETRF_AA,
202* > for the first block column, J1 is 1, hence J1+J-1 is J,
203* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
204*
205 k = j1+j-1
206 IF( j.EQ.m ) THEN
207*
208* Only need to compute T(J, J)
209*
210 mj = 1
211 ELSE
212 mj = m-j+1
213 END IF
214*
215* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J),
216* where H(J:N, J) has been initialized to be A(J, J:N)
217*
218 IF( k.GT.2 ) THEN
219*
220* K is the column to be factorized
221* > for the first block column, K is J, skipping the first two
222* columns
223* > for the rest of the columns, K is J+1, skipping only the
224* first column
225*
226 CALL clacgv( j-k1, a( 1, j ), 1 )
227 CALL cgemv( 'No transpose', mj, j-k1,
228 $ -one, h( j, k1 ), ldh,
229 $ a( 1, j ), 1,
230 $ one, h( j, j ), 1 )
231 CALL clacgv( j-k1, a( 1, j ), 1 )
232 END IF
233*
234* Copy H(i:n, i) into WORK
235*
236 CALL ccopy( mj, h( j, j ), 1, work( 1 ), 1 )
237*
238 IF( j.GT.k1 ) THEN
239*
240* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J),
241* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N)
242*
243 alpha = -conjg( a( k-1, j ) )
244 CALL caxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 )
245 END IF
246*
247* Set A(J, J) = T(J, J)
248*
249 a( k, j ) = real( work( 1 ) )
250*
251 IF( j.LT.m ) THEN
252*
253* Compute WORK(2:N) = T(J, J) L(J, (J+1):N)
254* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N)
255*
256 IF( k.GT.1 ) THEN
257 alpha = -a( k, j )
258 CALL caxpy( m-j, alpha, a( k-1, j+1 ), lda,
259 $ work( 2 ), 1 )
260 ENDIF
261*
262* Find max(|WORK(2:n)|)
263*
264 i2 = icamax( m-j, work( 2 ), 1 ) + 1
265 piv = work( i2 )
266*
267* Apply hermitian pivot
268*
269 IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
270*
271* Swap WORK(I1) and WORK(I2)
272*
273 i1 = 2
274 work( i2 ) = work( i1 )
275 work( i1 ) = piv
276*
277* Swap A(I1, I1+1:N) with A(I1+1:N, I2)
278*
279 i1 = i1+j-1
280 i2 = i2+j-1
281 CALL cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,
282 $ a( j1+i1, i2 ), 1 )
283 CALL clacgv( i2-i1, a( j1+i1-1, i1+1 ), lda )
284 CALL clacgv( i2-i1-1, a( j1+i1, i2 ), 1 )
285*
286* Swap A(I1, I2+1:N) with A(I2, I2+1:N)
287*
288 IF( i2.LT.m )
289 $ CALL cswap( m-i2, a( j1+i1-1, i2+1 ), lda,
290 $ a( j1+i2-1, i2+1 ), lda )
291*
292* Swap A(I1, I1) with A(I2,I2)
293*
294 piv = a( i1+j1-1, i1 )
295 a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
296 a( j1+i2-1, i2 ) = piv
297*
298* Swap H(I1, 1:J1) with H(I2, 1:J1)
299*
300 CALL cswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
301 ipiv( i1 ) = i2
302*
303 IF( i1.GT.(k1-1) ) THEN
304*
305* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
306* skipping the first column
307*
308 CALL cswap( i1-k1+1, a( 1, i1 ), 1,
309 $ a( 1, i2 ), 1 )
310 END IF
311 ELSE
312 ipiv( j+1 ) = j+1
313 ENDIF
314*
315* Set A(J, J+1) = T(J, J+1)
316*
317 a( k, j+1 ) = work( 2 )
318*
319 IF( j.LT.nb ) THEN
320*
321* Copy A(J+1:N, J+1) into H(J:N, J),
322*
323 CALL ccopy( m-j, a( k+1, j+1 ), lda,
324 $ h( j+1, j+1 ), 1 )
325 END IF
326*
327* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1),
328* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1)
329*
330 IF( j.LT.(m-1) ) THEN
331 IF( a( k, j+1 ).NE.zero ) THEN
332 alpha = one / a( k, j+1 )
333 CALL ccopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
334 CALL cscal( m-j-1, alpha, a( k, j+2 ), lda )
335 ELSE
336 CALL claset( 'Full', 1, m-j-1, zero, zero,
337 $ a( k, j+2 ), lda)
338 END IF
339 END IF
340 END IF
341 j = j + 1
342 GO TO 10
343 20 CONTINUE
344*
345 ELSE
346*
347* .....................................................
348* Factorize A as L*D*L**T using the lower triangle of A
349* .....................................................
350*
351 30 CONTINUE
352 IF( j.GT.min( m, nb ) )
353 $ GO TO 40
354*
355* K is the column to be factorized
356* when being called from CHETRF_AA,
357* > for the first block column, J1 is 1, hence J1+J-1 is J,
358* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
359*
360 k = j1+j-1
361 IF( j.EQ.m ) THEN
362*
363* Only need to compute T(J, J)
364*
365 mj = 1
366 ELSE
367 mj = m-j+1
368 END IF
369*
370* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T,
371* where H(J:N, J) has been initialized to be A(J:N, J)
372*
373 IF( k.GT.2 ) THEN
374*
375* K is the column to be factorized
376* > for the first block column, K is J, skipping the first two
377* columns
378* > for the rest of the columns, K is J+1, skipping only the
379* first column
380*
381 CALL clacgv( j-k1, a( j, 1 ), lda )
382 CALL cgemv( 'No transpose', mj, j-k1,
383 $ -one, h( j, k1 ), ldh,
384 $ a( j, 1 ), lda,
385 $ one, h( j, j ), 1 )
386 CALL clacgv( j-k1, a( j, 1 ), lda )
387 END IF
388*
389* Copy H(J:N, J) into WORK
390*
391 CALL ccopy( mj, h( j, j ), 1, work( 1 ), 1 )
392*
393 IF( j.GT.k1 ) THEN
394*
395* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J),
396* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1)
397*
398 alpha = -conjg( a( j, k-1 ) )
399 CALL caxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 )
400 END IF
401*
402* Set A(J, J) = T(J, J)
403*
404 a( j, k ) = real( work( 1 ) )
405*
406 IF( j.LT.m ) THEN
407*
408* Compute WORK(2:N) = T(J, J) L((J+1):N, J)
409* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J)
410*
411 IF( k.GT.1 ) THEN
412 alpha = -a( j, k )
413 CALL caxpy( m-j, alpha, a( j+1, k-1 ), 1,
414 $ work( 2 ), 1 )
415 ENDIF
416*
417* Find max(|WORK(2:n)|)
418*
419 i2 = icamax( m-j, work( 2 ), 1 ) + 1
420 piv = work( i2 )
421*
422* Apply hermitian pivot
423*
424 IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
425*
426* Swap WORK(I1) and WORK(I2)
427*
428 i1 = 2
429 work( i2 ) = work( i1 )
430 work( i1 ) = piv
431*
432* Swap A(I1+1:N, I1) with A(I2, I1+1:N)
433*
434 i1 = i1+j-1
435 i2 = i2+j-1
436 CALL cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,
437 $ a( i2, j1+i1 ), lda )
438 CALL clacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 )
439 CALL clacgv( i2-i1-1, a( i2, j1+i1 ), lda )
440*
441* Swap A(I2+1:N, I1) with A(I2+1:N, I2)
442*
443 IF( i2.LT.m )
444 $ CALL cswap( m-i2, a( i2+1, j1+i1-1 ), 1,
445 $ a( i2+1, j1+i2-1 ), 1 )
446*
447* Swap A(I1, I1) with A(I2, I2)
448*
449 piv = a( i1, j1+i1-1 )
450 a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
451 a( i2, j1+i2-1 ) = piv
452*
453* Swap H(I1, I1:J1) with H(I2, I2:J1)
454*
455 CALL cswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
456 ipiv( i1 ) = i2
457*
458 IF( i1.GT.(k1-1) ) THEN
459*
460* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
461* skipping the first column
462*
463 CALL cswap( i1-k1+1, a( i1, 1 ), lda,
464 $ a( i2, 1 ), lda )
465 END IF
466 ELSE
467 ipiv( j+1 ) = j+1
468 ENDIF
469*
470* Set A(J+1, J) = T(J+1, J)
471*
472 a( j+1, k ) = work( 2 )
473*
474 IF( j.LT.nb ) THEN
475*
476* Copy A(J+1:N, J+1) into H(J+1:N, J),
477*
478 CALL ccopy( m-j, a( j+1, k+1 ), 1,
479 $ h( j+1, j+1 ), 1 )
480 END IF
481*
482* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1),
483* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1)
484*
485 IF( j.LT.(m-1) ) THEN
486 IF( a( j+1, k ).NE.zero ) THEN
487 alpha = one / a( j+1, k )
488 CALL ccopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
489 CALL cscal( m-j-1, alpha, a( j+2, k ), 1 )
490 ELSE
491 CALL claset( 'Full', m-j-1, 1, zero, zero,
492 $ a( j+2, k ), lda )
493 END IF
494 END IF
495 END IF
496 j = j + 1
497 GO TO 30
498 40 CONTINUE
499 END IF
500 RETURN
501*
502* End of CLAHEF_AA
503*
icamax
integer function icamax(n, cx, incx)
ICAMAX
Definition icamax.f:71
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158

◆ clasyf()

subroutine clasyf ( character uplo,
integer n,
integer nb,
integer kb,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldw, * ) w,
integer ldw,
integer info )

CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.

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

Purpose:
!>
!> CLASYF computes a partial factorization of a complex symmetric matrix
!> A using the Bunch-Kaufman diagonal pivoting method. The partial
!> factorization has the form:
!>
!> A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
!>       ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
!>
!> A  =  ( L11  0 ) ( D    0  ) ( L11**T L21**T )  if UPLO = 'L'
!>       ( L21  I ) ( 0   A22 ) (  0       I    )
!>
!> where the order of D is at most NB. The actual order is returned in
!> the argument KB, and is either NB or NB-1, or N if N <= NB.
!> Note that U**T denotes the transpose of U.
!>
!> CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code
!> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!> A22 (if UPLO = 'L').
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The maximum number of columns of the matrix A that should be
!>          factored.  NB should be at least 2 to allow for 2-by-2 pivot
!>          blocks.
!>
[out]KB
!>          KB is INTEGER
!>          The number of columns of A that were actually factored.
!>          KB is either NB-1 or NB, or N if N <= NB.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, A contains details of the partial factorization.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>
!>          If UPLO = 'U':
!>             Only the last KB elements of IPIV are set.
!>
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>             interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) = IPIV(k-1) < 0, then rows and columns
!>             k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!>             is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>             Only the first KB elements of IPIV are set.
!>
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>             interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) = IPIV(k+1) < 0, then rows and columns
!>             k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
!>             is a 2-by-2 diagonal block.
!>
[out]W
!>          W is COMPLEX array, dimension (LDW,NB)
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array W.  LDW >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
!>               has been completed, but the block diagonal matrix D is
!>               exactly singular.
!>
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
!>

Definition at line 176 of file clasyf.f.

177*
178* -- LAPACK computational routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 CHARACTER UPLO
184 INTEGER INFO, KB, LDA, LDW, N, NB
185* ..
186* .. Array Arguments ..
187 INTEGER IPIV( * )
188 COMPLEX A( LDA, * ), W( LDW, * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 REAL ZERO, ONE
195 parameter( zero = 0.0e+0, one = 1.0e+0 )
196 REAL EIGHT, SEVTEN
197 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
198 COMPLEX CONE
199 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
200* ..
201* .. Local Scalars ..
202 INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
203 $ KSTEP, KW
204 REAL ABSAKK, ALPHA, COLMAX, ROWMAX
205 COMPLEX D11, D21, D22, R1, T, Z
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 INTEGER ICAMAX
210 EXTERNAL lsame, icamax
211* ..
212* .. External Subroutines ..
213 EXTERNAL ccopy, cgemm, cgemv, cscal, cswap
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC abs, aimag, max, min, real, sqrt
217* ..
218* .. Statement Functions ..
219 REAL CABS1
220* ..
221* .. Statement Function definitions ..
222 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
223* ..
224* .. Executable Statements ..
225*
226 info = 0
227*
228* Initialize ALPHA for use in choosing pivot block size.
229*
230 alpha = ( one+sqrt( sevten ) ) / eight
231*
232 IF( lsame( uplo, 'U' ) ) THEN
233*
234* Factorize the trailing columns of A using the upper triangle
235* of A and working backwards, and compute the matrix W = U12*D
236* for use in updating A11
237*
238* K is the main loop index, decreasing from N in steps of 1 or 2
239*
240* KW is the column of W which corresponds to column K of A
241*
242 k = n
243 10 CONTINUE
244 kw = nb + k - n
245*
246* Exit from loop
247*
248 IF( ( k.LE.n-nb+1 .AND. nb.LT.n ) .OR. k.LT.1 )
249 $ GO TO 30
250*
251* Copy column K of A to column KW of W and update it
252*
253 CALL ccopy( k, a( 1, k ), 1, w( 1, kw ), 1 )
254 IF( k.LT.n )
255 $ CALL cgemv( 'No transpose', k, n-k, -cone, a( 1, k+1 ), lda,
256 $ w( k, kw+1 ), ldw, cone, w( 1, kw ), 1 )
257*
258 kstep = 1
259*
260* Determine rows and columns to be interchanged and whether
261* a 1-by-1 or 2-by-2 pivot block will be used
262*
263 absakk = cabs1( w( k, kw ) )
264*
265* IMAX is the row-index of the largest off-diagonal element in
266* column K, and COLMAX is its absolute value.
267* Determine both COLMAX and IMAX.
268*
269 IF( k.GT.1 ) THEN
270 imax = icamax( k-1, w( 1, kw ), 1 )
271 colmax = cabs1( w( imax, kw ) )
272 ELSE
273 colmax = zero
274 END IF
275*
276 IF( max( absakk, colmax ).EQ.zero ) THEN
277*
278* Column K is zero or underflow: set INFO and continue
279*
280 IF( info.EQ.0 )
281 $ info = k
282 kp = k
283 ELSE
284 IF( absakk.GE.alpha*colmax ) THEN
285*
286* no interchange, use 1-by-1 pivot block
287*
288 kp = k
289 ELSE
290*
291* Copy column IMAX to column KW-1 of W and update it
292*
293 CALL ccopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 )
294 CALL ccopy( k-imax, a( imax, imax+1 ), lda,
295 $ w( imax+1, kw-1 ), 1 )
296 IF( k.LT.n )
297 $ CALL cgemv( 'No transpose', k, n-k, -cone,
298 $ a( 1, k+1 ), lda, w( imax, kw+1 ), ldw,
299 $ cone, w( 1, kw-1 ), 1 )
300*
301* JMAX is the column-index of the largest off-diagonal
302* element in row IMAX, and ROWMAX is its absolute value
303*
304 jmax = imax + icamax( k-imax, w( imax+1, kw-1 ), 1 )
305 rowmax = cabs1( w( jmax, kw-1 ) )
306 IF( imax.GT.1 ) THEN
307 jmax = icamax( imax-1, w( 1, kw-1 ), 1 )
308 rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) )
309 END IF
310*
311 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
312*
313* no interchange, use 1-by-1 pivot block
314*
315 kp = k
316 ELSE IF( cabs1( w( imax, kw-1 ) ).GE.alpha*rowmax ) THEN
317*
318* interchange rows and columns K and IMAX, use 1-by-1
319* pivot block
320*
321 kp = imax
322*
323* copy column KW-1 of W to column KW of W
324*
325 CALL ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
326 ELSE
327*
328* interchange rows and columns K-1 and IMAX, use 2-by-2
329* pivot block
330*
331 kp = imax
332 kstep = 2
333 END IF
334 END IF
335*
336* ============================================================
337*
338* KK is the column of A where pivoting step stopped
339*
340 kk = k - kstep + 1
341*
342* KKW is the column of W which corresponds to column KK of A
343*
344 kkw = nb + kk - n
345*
346* Interchange rows and columns KP and KK.
347* Updated column KP is already stored in column KKW of W.
348*
349 IF( kp.NE.kk ) THEN
350*
351* Copy non-updated column KK to column KP of submatrix A
352* at step K. No need to copy element into column K
353* (or K and K-1 for 2-by-2 pivot) of A, since these columns
354* will be later overwritten.
355*
356 a( kp, kp ) = a( kk, kk )
357 CALL ccopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
358 $ lda )
359 IF( kp.GT.1 )
360 $ CALL ccopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
361*
362* Interchange rows KK and KP in last K+1 to N columns of A
363* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
364* later overwritten). Interchange rows KK and KP
365* in last KKW to NB columns of W.
366*
367 IF( k.LT.n )
368 $ CALL cswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
369 $ lda )
370 CALL cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),
371 $ ldw )
372 END IF
373*
374 IF( kstep.EQ.1 ) THEN
375*
376* 1-by-1 pivot block D(k): column kw of W now holds
377*
378* W(kw) = U(k)*D(k),
379*
380* where U(k) is the k-th column of U
381*
382* Store subdiag. elements of column U(k)
383* and 1-by-1 block D(k) in column k of A.
384* NOTE: Diagonal element U(k,k) is a UNIT element
385* and not stored.
386* A(k,k) := D(k,k) = W(k,kw)
387* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
388*
389 CALL ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
390 r1 = cone / a( k, k )
391 CALL cscal( k-1, r1, a( 1, k ), 1 )
392*
393 ELSE
394*
395* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
396*
397* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
398*
399* where U(k) and U(k-1) are the k-th and (k-1)-th columns
400* of U
401*
402* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
403* block D(k-1:k,k-1:k) in columns k-1 and k of A.
404* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
405* block and not stored.
406* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
407* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
408* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
409*
410 IF( k.GT.2 ) THEN
411*
412* Compose the columns of the inverse of 2-by-2 pivot
413* block D in the following way to reduce the number
414* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
415* this inverse
416*
417* D**(-1) = ( d11 d21 )**(-1) =
418* ( d21 d22 )
419*
420* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
421* ( (-d21 ) ( d11 ) )
422*
423* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
424*
425* * ( ( d22/d21 ) ( -1 ) ) =
426* ( ( -1 ) ( d11/d21 ) )
427*
428* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
429* ( ( -1 ) ( D22 ) )
430*
431* = 1/d21 * T * ( ( D11 ) ( -1 ) )
432* ( ( -1 ) ( D22 ) )
433*
434* = D21 * ( ( D11 ) ( -1 ) )
435* ( ( -1 ) ( D22 ) )
436*
437 d21 = w( k-1, kw )
438 d11 = w( k, kw ) / d21
439 d22 = w( k-1, kw-1 ) / d21
440 t = cone / ( d11*d22-cone )
441*
442* Update elements in columns A(k-1) and A(k) as
443* dot products of rows of ( W(kw-1) W(kw) ) and columns
444* of D**(-1)
445*
446 d21 = t / d21
447 DO 20 j = 1, k - 2
448 a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
449 a( j, k ) = d21*( d22*w( j, kw )-w( j, kw-1 ) )
450 20 CONTINUE
451 END IF
452*
453* Copy D(k) to A
454*
455 a( k-1, k-1 ) = w( k-1, kw-1 )
456 a( k-1, k ) = w( k-1, kw )
457 a( k, k ) = w( k, kw )
458*
459 END IF
460*
461 END IF
462*
463* Store details of the interchanges in IPIV
464*
465 IF( kstep.EQ.1 ) THEN
466 ipiv( k ) = kp
467 ELSE
468 ipiv( k ) = -kp
469 ipiv( k-1 ) = -kp
470 END IF
471*
472* Decrease K and return to the start of the main loop
473*
474 k = k - kstep
475 GO TO 10
476*
477 30 CONTINUE
478*
479* Update the upper triangle of A11 (= A(1:k,1:k)) as
480*
481* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
482*
483* computing blocks of NB columns at a time
484*
485 DO 50 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
486 jb = min( nb, k-j+1 )
487*
488* Update the upper triangle of the diagonal block
489*
490 DO 40 jj = j, j + jb - 1
491 CALL cgemv( 'No transpose', jj-j+1, n-k, -cone,
492 $ a( j, k+1 ), lda, w( jj, kw+1 ), ldw, cone,
493 $ a( j, jj ), 1 )
494 40 CONTINUE
495*
496* Update the rectangular superdiagonal block
497*
498 CALL cgemm( 'No transpose', 'Transpose', j-1, jb, n-k,
499 $ -cone, a( 1, k+1 ), lda, w( j, kw+1 ), ldw,
500 $ cone, a( 1, j ), lda )
501 50 CONTINUE
502*
503* Put U12 in standard form by partially undoing the interchanges
504* in columns k+1:n looping backwards from k+1 to n
505*
506 j = k + 1
507 60 CONTINUE
508*
509* Undo the interchanges (if any) of rows JJ and JP at each
510* step J
511*
512* (Here, J is a diagonal index)
513 jj = j
514 jp = ipiv( j )
515 IF( jp.LT.0 ) THEN
516 jp = -jp
517* (Here, J is a diagonal index)
518 j = j + 1
519 END IF
520* (NOTE: Here, J is used to determine row length. Length N-J+1
521* of the rows to swap back doesn't include diagonal element)
522 j = j + 1
523 IF( jp.NE.jj .AND. j.LE.n )
524 $ CALL cswap( n-j+1, a( jp, j ), lda, a( jj, j ), lda )
525 IF( j.LT.n )
526 $ GO TO 60
527*
528* Set KB to the number of columns factorized
529*
530 kb = n - k
531*
532 ELSE
533*
534* Factorize the leading columns of A using the lower triangle
535* of A and working forwards, and compute the matrix W = L21*D
536* for use in updating A22
537*
538* K is the main loop index, increasing from 1 in steps of 1 or 2
539*
540 k = 1
541 70 CONTINUE
542*
543* Exit from loop
544*
545 IF( ( k.GE.nb .AND. nb.LT.n ) .OR. k.GT.n )
546 $ GO TO 90
547*
548* Copy column K of A to column K of W and update it
549*
550 CALL ccopy( n-k+1, a( k, k ), 1, w( k, k ), 1 )
551 CALL cgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ), lda,
552 $ w( k, 1 ), ldw, cone, w( k, k ), 1 )
553*
554 kstep = 1
555*
556* Determine rows and columns to be interchanged and whether
557* a 1-by-1 or 2-by-2 pivot block will be used
558*
559 absakk = cabs1( w( k, k ) )
560*
561* IMAX is the row-index of the largest off-diagonal element in
562* column K, and COLMAX is its absolute value.
563* Determine both COLMAX and IMAX.
564*
565 IF( k.LT.n ) THEN
566 imax = k + icamax( n-k, w( k+1, k ), 1 )
567 colmax = cabs1( w( imax, k ) )
568 ELSE
569 colmax = zero
570 END IF
571*
572 IF( max( absakk, colmax ).EQ.zero ) THEN
573*
574* Column K is zero or underflow: set INFO and continue
575*
576 IF( info.EQ.0 )
577 $ info = k
578 kp = k
579 ELSE
580 IF( absakk.GE.alpha*colmax ) THEN
581*
582* no interchange, use 1-by-1 pivot block
583*
584 kp = k
585 ELSE
586*
587* Copy column IMAX to column K+1 of W and update it
588*
589 CALL ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 )
590 CALL ccopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),
591 $ 1 )
592 CALL cgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ),
593 $ lda, w( imax, 1 ), ldw, cone, w( k, k+1 ),
594 $ 1 )
595*
596* JMAX is the column-index of the largest off-diagonal
597* element in row IMAX, and ROWMAX is its absolute value
598*
599 jmax = k - 1 + icamax( imax-k, w( k, k+1 ), 1 )
600 rowmax = cabs1( w( jmax, k+1 ) )
601 IF( imax.LT.n ) THEN
602 jmax = imax + icamax( n-imax, w( imax+1, k+1 ), 1 )
603 rowmax = max( rowmax, cabs1( w( jmax, k+1 ) ) )
604 END IF
605*
606 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
607*
608* no interchange, use 1-by-1 pivot block
609*
610 kp = k
611 ELSE IF( cabs1( w( imax, k+1 ) ).GE.alpha*rowmax ) THEN
612*
613* interchange rows and columns K and IMAX, use 1-by-1
614* pivot block
615*
616 kp = imax
617*
618* copy column K+1 of W to column K of W
619*
620 CALL ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
621 ELSE
622*
623* interchange rows and columns K+1 and IMAX, use 2-by-2
624* pivot block
625*
626 kp = imax
627 kstep = 2
628 END IF
629 END IF
630*
631* ============================================================
632*
633* KK is the column of A where pivoting step stopped
634*
635 kk = k + kstep - 1
636*
637* Interchange rows and columns KP and KK.
638* Updated column KP is already stored in column KK of W.
639*
640 IF( kp.NE.kk ) THEN
641*
642* Copy non-updated column KK to column KP of submatrix A
643* at step K. No need to copy element into column K
644* (or K and K+1 for 2-by-2 pivot) of A, since these columns
645* will be later overwritten.
646*
647 a( kp, kp ) = a( kk, kk )
648 CALL ccopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
649 $ lda )
650 IF( kp.LT.n )
651 $ CALL ccopy( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
652*
653* Interchange rows KK and KP in first K-1 columns of A
654* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
655* later overwritten). Interchange rows KK and KP
656* in first KK columns of W.
657*
658 IF( k.GT.1 )
659 $ CALL cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
660 CALL cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw )
661 END IF
662*
663 IF( kstep.EQ.1 ) THEN
664*
665* 1-by-1 pivot block D(k): column k of W now holds
666*
667* W(k) = L(k)*D(k),
668*
669* where L(k) is the k-th column of L
670*
671* Store subdiag. elements of column L(k)
672* and 1-by-1 block D(k) in column k of A.
673* (NOTE: Diagonal element L(k,k) is a UNIT element
674* and not stored)
675* A(k,k) := D(k,k) = W(k,k)
676* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
677*
678 CALL ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
679 IF( k.LT.n ) THEN
680 r1 = cone / a( k, k )
681 CALL cscal( n-k, r1, a( k+1, k ), 1 )
682 END IF
683*
684 ELSE
685*
686* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
687*
688* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
689*
690* where L(k) and L(k+1) are the k-th and (k+1)-th columns
691* of L
692*
693* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
694* block D(k:k+1,k:k+1) in columns k and k+1 of A.
695* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
696* block and not stored)
697* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
698* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
699* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
700*
701 IF( k.LT.n-1 ) THEN
702*
703* Compose the columns of the inverse of 2-by-2 pivot
704* block D in the following way to reduce the number
705* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
706* this inverse
707*
708* D**(-1) = ( d11 d21 )**(-1) =
709* ( d21 d22 )
710*
711* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
712* ( (-d21 ) ( d11 ) )
713*
714* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
715*
716* * ( ( d22/d21 ) ( -1 ) ) =
717* ( ( -1 ) ( d11/d21 ) )
718*
719* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
720* ( ( -1 ) ( D22 ) )
721*
722* = 1/d21 * T * ( ( D11 ) ( -1 ) )
723* ( ( -1 ) ( D22 ) )
724*
725* = D21 * ( ( D11 ) ( -1 ) )
726* ( ( -1 ) ( D22 ) )
727*
728 d21 = w( k+1, k )
729 d11 = w( k+1, k+1 ) / d21
730 d22 = w( k, k ) / d21
731 t = cone / ( d11*d22-cone )
732 d21 = t / d21
733*
734* Update elements in columns A(k) and A(k+1) as
735* dot products of rows of ( W(k) W(k+1) ) and columns
736* of D**(-1)
737*
738 DO 80 j = k + 2, n
739 a( j, k ) = d21*( d11*w( j, k )-w( j, k+1 ) )
740 a( j, k+1 ) = d21*( d22*w( j, k+1 )-w( j, k ) )
741 80 CONTINUE
742 END IF
743*
744* Copy D(k) to A
745*
746 a( k, k ) = w( k, k )
747 a( k+1, k ) = w( k+1, k )
748 a( k+1, k+1 ) = w( k+1, k+1 )
749*
750 END IF
751*
752 END IF
753*
754* Store details of the interchanges in IPIV
755*
756 IF( kstep.EQ.1 ) THEN
757 ipiv( k ) = kp
758 ELSE
759 ipiv( k ) = -kp
760 ipiv( k+1 ) = -kp
761 END IF
762*
763* Increase K and return to the start of the main loop
764*
765 k = k + kstep
766 GO TO 70
767*
768 90 CONTINUE
769*
770* Update the lower triangle of A22 (= A(k:n,k:n)) as
771*
772* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
773*
774* computing blocks of NB columns at a time
775*
776 DO 110 j = k, n, nb
777 jb = min( nb, n-j+1 )
778*
779* Update the lower triangle of the diagonal block
780*
781 DO 100 jj = j, j + jb - 1
782 CALL cgemv( 'No transpose', j+jb-jj, k-1, -cone,
783 $ a( jj, 1 ), lda, w( jj, 1 ), ldw, cone,
784 $ a( jj, jj ), 1 )
785 100 CONTINUE
786*
787* Update the rectangular subdiagonal block
788*
789 IF( j+jb.LE.n )
790 $ CALL cgemm( 'No transpose', 'Transpose', n-j-jb+1, jb,
791 $ k-1, -cone, a( j+jb, 1 ), lda, w( j, 1 ),
792 $ ldw, cone, a( j+jb, j ), lda )
793 110 CONTINUE
794*
795* Put L21 in standard form by partially undoing the interchanges
796* of rows in columns 1:k-1 looping backwards from k-1 to 1
797*
798 j = k - 1
799 120 CONTINUE
800*
801* Undo the interchanges (if any) of rows JJ and JP at each
802* step J
803*
804* (Here, J is a diagonal index)
805 jj = j
806 jp = ipiv( j )
807 IF( jp.LT.0 ) THEN
808 jp = -jp
809* (Here, J is a diagonal index)
810 j = j - 1
811 END IF
812* (NOTE: Here, J is used to determine row length. Length J
813* of the rows to swap back doesn't include diagonal element)
814 j = j - 1
815 IF( jp.NE.jj .AND. j.GE.1 )
816 $ CALL cswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda )
817 IF( j.GT.1 )
818 $ GO TO 120
819*
820* Set KB to the number of columns factorized
821*
822 kb = k - 1
823*
824 END IF
825 RETURN
826*
827* End of CLASYF
828*

◆ clasyf_aa()

subroutine clasyf_aa ( character uplo,
integer j1,
integer m,
integer nb,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( * ) work )

CLASYF_AA

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

Purpose:
!>
!> DLATRF_AA factorizes a panel of a complex symmetric matrix A using
!> the Aasen's algorithm. The panel consists of a set of NB rows of A
!> when UPLO is U, or a set of NB columns when UPLO is L.
!>
!> In order to factorize the panel, the Aasen's algorithm requires the
!> last row, or column, of the previous panel. The first row, or column,
!> of A is set to be the first row, or column, of an identity matrix,
!> which is used to factorize the first panel.
!>
!> The resulting J-th row of U, or J-th column of L, is stored in the
!> (J-1)-th row, or column, of A (without the unit diagonals), while
!> the diagonal and subdiagonal of A are overwritten by those of T.
!>
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]J1
!>          J1 is INTEGER
!>          The location of the first row, or column, of the panel
!>          within the submatrix of A, passed to this routine, e.g.,
!>          when called by CSYTRF_AA, for the first panel, J1 is 1,
!>          while for the remaining panels, J1 is 2.
!>
[in]M
!>          M is INTEGER
!>          The dimension of the submatrix. M >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The dimension of the panel to be facotorized.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,M) for
!>          the first panel, while dimension (LDA,M+1) for the
!>          remaining panels.
!>
!>          On entry, A contains the last row, or column, of
!>          the previous panel, and the trailing submatrix of A
!>          to be factorized, except for the first panel, only
!>          the panel is passed.
!>
!>          On exit, the leading panel is factorized.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (M)
!>          Details of the row and column interchanges,
!>          the row and column k were interchanged with the row and
!>          column IPIV(k).
!>
[in,out]H
!>          H is COMPLEX workspace, dimension (LDH,NB).
!>
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the workspace H. LDH >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX workspace, dimension (M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file clasyf_aa.f.

144*
145* -- LAPACK computational routine --
146* -- LAPACK is a software package provided by Univ. of Tennessee, --
147* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
148*
149 IMPLICIT NONE
150*
151* .. Scalar Arguments ..
152 CHARACTER UPLO
153 INTEGER M, NB, J1, LDA, LDH
154* ..
155* .. Array Arguments ..
156 INTEGER IPIV( * )
157 COMPLEX A( LDA, * ), H( LDH, * ), WORK( * )
158* ..
159*
160* =====================================================================
161* .. Parameters ..
162 COMPLEX ZERO, ONE
163 parameter( zero = 0.0e+0, one = 1.0e+0 )
164*
165* .. Local Scalars ..
166 INTEGER J, K, K1, I1, I2, MJ
167 COMPLEX PIV, ALPHA
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER ICAMAX, ILAENV
172 EXTERNAL lsame, ilaenv, icamax
173* ..
174* .. External Subroutines ..
175 EXTERNAL caxpy, cgemv, cscal, ccopy, cswap, claset,
176 $ xerbla
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC max
180* ..
181* .. Executable Statements ..
182*
183 j = 1
184*
185* K1 is the first column of the panel to be factorized
186* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks
187*
188 k1 = (2-j1)+1
189*
190 IF( lsame( uplo, 'U' ) ) THEN
191*
192* .....................................................
193* Factorize A as U**T*D*U using the upper triangle of A
194* .....................................................
195*
196 10 CONTINUE
197 IF ( j.GT.min(m, nb) )
198 $ GO TO 20
199*
200* K is the column to be factorized
201* when being called from CSYTRF_AA,
202* > for the first block column, J1 is 1, hence J1+J-1 is J,
203* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
204*
205 k = j1+j-1
206 IF( j.EQ.m ) THEN
207*
208* Only need to compute T(J, J)
209*
210 mj = 1
211 ELSE
212 mj = m-j+1
213 END IF
214*
215* H(J:M, J) := A(J, J:M) - H(J:M, 1:(J-1)) * L(J1:(J-1), J),
216* where H(J:M, J) has been initialized to be A(J, J:M)
217*
218 IF( k.GT.2 ) THEN
219*
220* K is the column to be factorized
221* > for the first block column, K is J, skipping the first two
222* columns
223* > for the rest of the columns, K is J+1, skipping only the
224* first column
225*
226 CALL cgemv( 'No transpose', mj, j-k1,
227 $ -one, h( j, k1 ), ldh,
228 $ a( 1, j ), 1,
229 $ one, h( j, j ), 1 )
230 END IF
231*
232* Copy H(i:M, i) into WORK
233*
234 CALL ccopy( mj, h( j, j ), 1, work( 1 ), 1 )
235*
236 IF( j.GT.k1 ) THEN
237*
238* Compute WORK := WORK - L(J-1, J:M) * T(J-1,J),
239* where A(J-1, J) stores T(J-1, J) and A(J-2, J:M) stores U(J-1, J:M)
240*
241 alpha = -a( k-1, j )
242 CALL caxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 )
243 END IF
244*
245* Set A(J, J) = T(J, J)
246*
247 a( k, j ) = work( 1 )
248*
249 IF( j.LT.m ) THEN
250*
251* Compute WORK(2:M) = T(J, J) L(J, (J+1):M)
252* where A(J, J) stores T(J, J) and A(J-1, (J+1):M) stores U(J, (J+1):M)
253*
254 IF( k.GT.1 ) THEN
255 alpha = -a( k, j )
256 CALL caxpy( m-j, alpha, a( k-1, j+1 ), lda,
257 $ work( 2 ), 1 )
258 ENDIF
259*
260* Find max(|WORK(2:M)|)
261*
262 i2 = icamax( m-j, work( 2 ), 1 ) + 1
263 piv = work( i2 )
264*
265* Apply symmetric pivot
266*
267 IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
268*
269* Swap WORK(I1) and WORK(I2)
270*
271 i1 = 2
272 work( i2 ) = work( i1 )
273 work( i1 ) = piv
274*
275* Swap A(I1, I1+1:M) with A(I1+1:M, I2)
276*
277 i1 = i1+j-1
278 i2 = i2+j-1
279 CALL cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,
280 $ a( j1+i1, i2 ), 1 )
281*
282* Swap A(I1, I2+1:M) with A(I2, I2+1:M)
283*
284 IF( i2.LT.m )
285 $ CALL cswap( m-i2, a( j1+i1-1, i2+1 ), lda,
286 $ a( j1+i2-1, i2+1 ), lda )
287*
288* Swap A(I1, I1) with A(I2,I2)
289*
290 piv = a( i1+j1-1, i1 )
291 a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
292 a( j1+i2-1, i2 ) = piv
293*
294* Swap H(I1, 1:J1) with H(I2, 1:J1)
295*
296 CALL cswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
297 ipiv( i1 ) = i2
298*
299 IF( i1.GT.(k1-1) ) THEN
300*
301* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
302* skipping the first column
303*
304 CALL cswap( i1-k1+1, a( 1, i1 ), 1,
305 $ a( 1, i2 ), 1 )
306 END IF
307 ELSE
308 ipiv( j+1 ) = j+1
309 ENDIF
310*
311* Set A(J, J+1) = T(J, J+1)
312*
313 a( k, j+1 ) = work( 2 )
314*
315 IF( j.LT.nb ) THEN
316*
317* Copy A(J+1:M, J+1) into H(J:M, J),
318*
319 CALL ccopy( m-j, a( k+1, j+1 ), lda,
320 $ h( j+1, j+1 ), 1 )
321 END IF
322*
323* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1),
324* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1)
325*
326 IF( j.LT.(m-1) ) THEN
327 IF( a( k, j+1 ).NE.zero ) THEN
328 alpha = one / a( k, j+1 )
329 CALL ccopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
330 CALL cscal( m-j-1, alpha, a( k, j+2 ), lda )
331 ELSE
332 CALL claset( 'Full', 1, m-j-1, zero, zero,
333 $ a( k, j+2 ), lda)
334 END IF
335 END IF
336 END IF
337 j = j + 1
338 GO TO 10
339 20 CONTINUE
340*
341 ELSE
342*
343* .....................................................
344* Factorize A as L*D*L**T using the lower triangle of A
345* .....................................................
346*
347 30 CONTINUE
348 IF( j.GT.min( m, nb ) )
349 $ GO TO 40
350*
351* K is the column to be factorized
352* when being called from CSYTRF_AA,
353* > for the first block column, J1 is 1, hence J1+J-1 is J,
354* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1,
355*
356 k = j1+j-1
357 IF( j.EQ.m ) THEN
358*
359* Only need to compute T(J, J)
360*
361 mj = 1
362 ELSE
363 mj = m-j+1
364 END IF
365*
366* H(J:M, J) := A(J:M, J) - H(J:M, 1:(J-1)) * L(J, J1:(J-1))^T,
367* where H(J:M, J) has been initialized to be A(J:M, J)
368*
369 IF( k.GT.2 ) THEN
370*
371* K is the column to be factorized
372* > for the first block column, K is J, skipping the first two
373* columns
374* > for the rest of the columns, K is J+1, skipping only the
375* first column
376*
377 CALL cgemv( 'No transpose', mj, j-k1,
378 $ -one, h( j, k1 ), ldh,
379 $ a( j, 1 ), lda,
380 $ one, h( j, j ), 1 )
381 END IF
382*
383* Copy H(J:M, J) into WORK
384*
385 CALL ccopy( mj, h( j, j ), 1, work( 1 ), 1 )
386*
387 IF( j.GT.k1 ) THEN
388*
389* Compute WORK := WORK - L(J:M, J-1) * T(J-1,J),
390* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1)
391*
392 alpha = -a( j, k-1 )
393 CALL caxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 )
394 END IF
395*
396* Set A(J, J) = T(J, J)
397*
398 a( j, k ) = work( 1 )
399*
400 IF( j.LT.m ) THEN
401*
402* Compute WORK(2:M) = T(J, J) L((J+1):M, J)
403* where A(J, J) = T(J, J) and A((J+1):M, J-1) = L((J+1):M, J)
404*
405 IF( k.GT.1 ) THEN
406 alpha = -a( j, k )
407 CALL caxpy( m-j, alpha, a( j+1, k-1 ), 1,
408 $ work( 2 ), 1 )
409 ENDIF
410*
411* Find max(|WORK(2:M)|)
412*
413 i2 = icamax( m-j, work( 2 ), 1 ) + 1
414 piv = work( i2 )
415*
416* Apply symmetric pivot
417*
418 IF( (i2.NE.2) .AND. (piv.NE.0) ) THEN
419*
420* Swap WORK(I1) and WORK(I2)
421*
422 i1 = 2
423 work( i2 ) = work( i1 )
424 work( i1 ) = piv
425*
426* Swap A(I1+1:M, I1) with A(I2, I1+1:M)
427*
428 i1 = i1+j-1
429 i2 = i2+j-1
430 CALL cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,
431 $ a( i2, j1+i1 ), lda )
432*
433* Swap A(I2+1:M, I1) with A(I2+1:M, I2)
434*
435 IF( i2.LT.m )
436 $ CALL cswap( m-i2, a( i2+1, j1+i1-1 ), 1,
437 $ a( i2+1, j1+i2-1 ), 1 )
438*
439* Swap A(I1, I1) with A(I2, I2)
440*
441 piv = a( i1, j1+i1-1 )
442 a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
443 a( i2, j1+i2-1 ) = piv
444*
445* Swap H(I1, I1:J1) with H(I2, I2:J1)
446*
447 CALL cswap( i1-1, h( i1, 1 ), ldh, h( i2, 1 ), ldh )
448 ipiv( i1 ) = i2
449*
450 IF( i1.GT.(k1-1) ) THEN
451*
452* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
453* skipping the first column
454*
455 CALL cswap( i1-k1+1, a( i1, 1 ), lda,
456 $ a( i2, 1 ), lda )
457 END IF
458 ELSE
459 ipiv( j+1 ) = j+1
460 ENDIF
461*
462* Set A(J+1, J) = T(J+1, J)
463*
464 a( j+1, k ) = work( 2 )
465*
466 IF( j.LT.nb ) THEN
467*
468* Copy A(J+1:M, J+1) into H(J+1:M, J),
469*
470 CALL ccopy( m-j, a( j+1, k+1 ), 1,
471 $ h( j+1, j+1 ), 1 )
472 END IF
473*
474* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1),
475* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1)
476*
477 IF( j.LT.(m-1) ) THEN
478 IF( a( j+1, k ).NE.zero ) THEN
479 alpha = one / a( j+1, k )
480 CALL ccopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
481 CALL cscal( m-j-1, alpha, a( j+2, k ), 1 )
482 ELSE
483 CALL claset( 'Full', m-j-1, 1, zero, zero,
484 $ a( j+2, k ), lda )
485 END IF
486 END IF
487 END IF
488 j = j + 1
489 GO TO 30
490 40 CONTINUE
491 END IF
492 RETURN
493*
494* End of CLASYF_AA
495*

◆ clasyf_rk()

subroutine clasyf_rk ( character uplo,
integer n,
integer nb,
integer kb,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( ldw, * ) w,
integer ldw,
integer info )

CLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.

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

Purpose:
!> CLASYF_RK computes a partial factorization of a complex symmetric
!> matrix A using the bounded Bunch-Kaufman (rook) diagonal
!> pivoting method. The partial factorization has the form:
!>
!> A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
!>       ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
!>
!> A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L',
!>       ( L21  I ) (  0  A22 ) (  0       I    )
!>
!> where the order of D is at most NB. The actual order is returned in
!> the argument KB, and is either NB or NB-1, or N if N <= NB.
!>
!> CLASYF_RK is an auxiliary routine called by CSYTRF_RK. It uses
!> blocked code (calling Level 3 BLAS) to update the submatrix
!> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The maximum number of columns of the matrix A that should be
!>          factored.  NB should be at least 2 to allow for 2-by-2 pivot
!>          blocks.
!>
[out]KB
!>          KB is INTEGER
!>          The number of columns of A that were actually factored.
!>          KB is either NB-1 or NB, or N if N <= NB.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.
!>            If UPLO = 'U': the leading N-by-N upper triangular part
!>            of A contains the upper triangular part of the matrix A,
!>            and the strictly lower triangular part of A is not
!>            referenced.
!>
!>            If UPLO = 'L': the leading N-by-N lower triangular part
!>            of A contains the lower triangular part of the matrix A,
!>            and the strictly upper triangular part of A is not
!>            referenced.
!>
!>          On exit, contains:
!>            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
!>                are stored on exit 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]E
!>          E is COMPLEX array, dimension (N)
!>          On exit, 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) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is set to 0 in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          IPIV describes the permutation matrix P in the factorization
!>          of matrix A as follows. The absolute value of IPIV(k)
!>          represents the index of row and column that were
!>          interchanged with the k-th row and column. The value of UPLO
!>          describes the order in which the interchanges were applied.
!>          Also, the sign of IPIV represents the block structure of
!>          the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
!>          diagonal blocks which correspond to 1 or 2 interchanges
!>          at each factorization step.
!>
!>          If UPLO = 'U',
!>          ( in factorization order, k decreases from N to 1 ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the submatrix A(1:N,N-KB+1:N);
!>               If IPIV(k) = k, no interchange occurred.
!>
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k-1) < 0 means:
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,N-KB+1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k-1) != k-1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the submatrix A(1:N,N-KB+1:N).
!>                  If -IPIV(k-1) = k-1, no interchange occurred.
!>
!>            c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
!>          If UPLO = 'L',
!>          ( in factorization order, k increases from 1 to N ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the submatrix A(1:N,1:KB).
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k+1) < 0 means:
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the submatrix A(1:N,1:KB).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k+1) != k+1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the submatrix A(1:N,1:KB).
!>                  If -IPIV(k+1) = k+1, no interchange occurred.
!>
!>            c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
[out]W
!>          W is COMPLEX array, dimension (LDW,NB)
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array W.  LDW >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>
!>          < 0: If INFO = -k, the k-th argument had an illegal value
!>
!>          > 0: If INFO = k, the matrix A is singular, because:
!>                 If UPLO = 'U': column k in the upper
!>                 triangular part of A contains all zeros.
!>                 If UPLO = 'L': column k in the lower
!>                 triangular part of A contains all zeros.
!>
!>               Therefore D(k,k) is exactly zero, and superdiagonal
!>               elements of column k of U (or subdiagonal elements of
!>               column k of L ) are all zeros. The factorization has
!>               been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if
!>               it is used to solve a system of equations.
!>
!>               NOTE: INFO only stores the first occurrence of
!>               a singularity, any subsequent occurrence of singularity
!>               is not stored in INFO even though the factorization
!>               always completes.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>  December 2016,  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 260 of file clasyf_rk.f.

262*
263* -- LAPACK computational routine --
264* -- LAPACK is a software package provided by Univ. of Tennessee, --
265* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
266*
267* .. Scalar Arguments ..
268 CHARACTER UPLO
269 INTEGER INFO, KB, LDA, LDW, N, NB
270* ..
271* .. Array Arguments ..
272 INTEGER IPIV( * )
273 COMPLEX A( LDA, * ), E( * ), W( LDW, * )
274* ..
275*
276* =====================================================================
277*
278* .. Parameters ..
279 REAL ZERO, ONE
280 parameter( zero = 0.0e+0, one = 1.0e+0 )
281 REAL EIGHT, SEVTEN
282 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
283 COMPLEX CONE, CZERO
284 parameter( cone = ( 1.0e+0, 0.0e+0 ),
285 $ czero = ( 0.0e+0, 0.0e+0 ) )
286* ..
287* .. Local Scalars ..
288 LOGICAL DONE
289 INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW,
290 $ KP, KSTEP, P, II
291 REAL ABSAKK, ALPHA, COLMAX, ROWMAX, SFMIN, STEMP
292 COMPLEX D11, D12, D21, D22, R1, T, Z
293* ..
294* .. External Functions ..
295 LOGICAL LSAME
296 INTEGER ICAMAX
297 REAL SLAMCH
298 EXTERNAL lsame, icamax, slamch
299* ..
300* .. External Subroutines ..
301 EXTERNAL ccopy, cgemm, cgemv, cscal, cswap
302* ..
303* .. Intrinsic Functions ..
304 INTRINSIC abs, aimag, max, min, real, sqrt
305* ..
306* .. Statement Functions ..
307 REAL CABS1
308* ..
309* .. Statement Function definitions ..
310 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
311* ..
312* .. Executable Statements ..
313*
314 info = 0
315*
316* Initialize ALPHA for use in choosing pivot block size.
317*
318 alpha = ( one+sqrt( sevten ) ) / eight
319*
320* Compute machine safe minimum
321*
322 sfmin = slamch( 'S' )
323*
324 IF( lsame( uplo, 'U' ) ) THEN
325*
326* Factorize the trailing columns of A using the upper triangle
327* of A and working backwards, and compute the matrix W = U12*D
328* for use in updating A11
329*
330* Initialize the first entry of array E, where superdiagonal
331* elements of D are stored
332*
333 e( 1 ) = czero
334*
335* K is the main loop index, decreasing from N in steps of 1 or 2
336*
337 k = n
338 10 CONTINUE
339*
340* KW is the column of W which corresponds to column K of A
341*
342 kw = nb + k - n
343*
344* Exit from loop
345*
346 IF( ( k.LE.n-nb+1 .AND. nb.LT.n ) .OR. k.LT.1 )
347 $ GO TO 30
348*
349 kstep = 1
350 p = k
351*
352* Copy column K of A to column KW of W and update it
353*
354 CALL ccopy( k, a( 1, k ), 1, w( 1, kw ), 1 )
355 IF( k.LT.n )
356 $ CALL cgemv( 'No transpose', k, n-k, -cone, a( 1, k+1 ),
357 $ lda, w( k, kw+1 ), ldw, cone, w( 1, kw ), 1 )
358*
359* Determine rows and columns to be interchanged and whether
360* a 1-by-1 or 2-by-2 pivot block will be used
361*
362 absakk = cabs1( w( k, kw ) )
363*
364* IMAX is the row-index of the largest off-diagonal element in
365* column K, and COLMAX is its absolute value.
366* Determine both COLMAX and IMAX.
367*
368 IF( k.GT.1 ) THEN
369 imax = icamax( k-1, w( 1, kw ), 1 )
370 colmax = cabs1( w( imax, kw ) )
371 ELSE
372 colmax = zero
373 END IF
374*
375 IF( max( absakk, colmax ).EQ.zero ) THEN
376*
377* Column K is zero or underflow: set INFO and continue
378*
379 IF( info.EQ.0 )
380 $ info = k
381 kp = k
382 CALL ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
383*
384* Set E( K ) to zero
385*
386 IF( k.GT.1 )
387 $ e( k ) = czero
388*
389 ELSE
390*
391* ============================================================
392*
393* Test for interchange
394*
395* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
396* (used to handle NaN and Inf)
397*
398 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
399*
400* no interchange, use 1-by-1 pivot block
401*
402 kp = k
403*
404 ELSE
405*
406 done = .false.
407*
408* Loop until pivot found
409*
410 12 CONTINUE
411*
412* Begin pivot search loop body
413*
414*
415* Copy column IMAX to column KW-1 of W and update it
416*
417 CALL ccopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 )
418 CALL ccopy( k-imax, a( imax, imax+1 ), lda,
419 $ w( imax+1, kw-1 ), 1 )
420*
421 IF( k.LT.n )
422 $ CALL cgemv( 'No transpose', k, n-k, -cone,
423 $ a( 1, k+1 ), lda, w( imax, kw+1 ), ldw,
424 $ cone, w( 1, kw-1 ), 1 )
425*
426* JMAX is the column-index of the largest off-diagonal
427* element in row IMAX, and ROWMAX is its absolute value.
428* Determine both ROWMAX and JMAX.
429*
430 IF( imax.NE.k ) THEN
431 jmax = imax + icamax( k-imax, w( imax+1, kw-1 ),
432 $ 1 )
433 rowmax = cabs1( w( jmax, kw-1 ) )
434 ELSE
435 rowmax = zero
436 END IF
437*
438 IF( imax.GT.1 ) THEN
439 itemp = icamax( imax-1, w( 1, kw-1 ), 1 )
440 stemp = cabs1( w( itemp, kw-1 ) )
441 IF( stemp.GT.rowmax ) THEN
442 rowmax = stemp
443 jmax = itemp
444 END IF
445 END IF
446*
447* Equivalent to testing for
448* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
449* (used to handle NaN and Inf)
450*
451 IF( .NOT.(cabs1( w( imax, kw-1 ) ).LT.alpha*rowmax ) )
452 $ THEN
453*
454* interchange rows and columns K and IMAX,
455* use 1-by-1 pivot block
456*
457 kp = imax
458*
459* copy column KW-1 of W to column KW of W
460*
461 CALL ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
462*
463 done = .true.
464*
465* Equivalent to testing for ROWMAX.EQ.COLMAX,
466* (used to handle NaN and Inf)
467*
468 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
469 $ THEN
470*
471* interchange rows and columns K-1 and IMAX,
472* use 2-by-2 pivot block
473*
474 kp = imax
475 kstep = 2
476 done = .true.
477 ELSE
478*
479* Pivot not found: set params and repeat
480*
481 p = imax
482 colmax = rowmax
483 imax = jmax
484*
485* Copy updated JMAXth (next IMAXth) column to Kth of W
486*
487 CALL ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
488*
489 END IF
490*
491* End pivot search loop body
492*
493 IF( .NOT. done ) GOTO 12
494*
495 END IF
496*
497* ============================================================
498*
499 kk = k - kstep + 1
500*
501* KKW is the column of W which corresponds to column KK of A
502*
503 kkw = nb + kk - n
504*
505 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
506*
507* Copy non-updated column K to column P
508*
509 CALL ccopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda )
510 CALL ccopy( p, a( 1, k ), 1, a( 1, p ), 1 )
511*
512* Interchange rows K and P in last N-K+1 columns of A
513* and last N-K+2 columns of W
514*
515 CALL cswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
516 CALL cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
517 END IF
518*
519* Updated column KP is already stored in column KKW of W
520*
521 IF( kp.NE.kk ) THEN
522*
523* Copy non-updated column KK to column KP
524*
525 a( kp, k ) = a( kk, k )
526 CALL ccopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
527 $ lda )
528 CALL ccopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 )
529*
530* Interchange rows KK and KP in last N-KK+1 columns
531* of A and W
532*
533 CALL cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
534 CALL cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),
535 $ ldw )
536 END IF
537*
538 IF( kstep.EQ.1 ) THEN
539*
540* 1-by-1 pivot block D(k): column KW of W now holds
541*
542* W(k) = U(k)*D(k)
543*
544* where U(k) is the k-th column of U
545*
546* Store U(k) in column k of A
547*
548 CALL ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
549 IF( k.GT.1 ) THEN
550 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
551 r1 = cone / a( k, k )
552 CALL cscal( k-1, r1, a( 1, k ), 1 )
553 ELSE IF( a( k, k ).NE.czero ) THEN
554 DO 14 ii = 1, k - 1
555 a( ii, k ) = a( ii, k ) / a( k, k )
556 14 CONTINUE
557 END IF
558*
559* Store the superdiagonal element of D in array E
560*
561 e( k ) = czero
562*
563 END IF
564*
565 ELSE
566*
567* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
568* hold
569*
570* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
571*
572* where U(k) and U(k-1) are the k-th and (k-1)-th columns
573* of U
574*
575 IF( k.GT.2 ) THEN
576*
577* Store U(k) and U(k-1) in columns k and k-1 of A
578*
579 d12 = w( k-1, kw )
580 d11 = w( k, kw ) / d12
581 d22 = w( k-1, kw-1 ) / d12
582 t = cone / ( d11*d22-cone )
583 DO 20 j = 1, k - 2
584 a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /
585 $ d12 )
586 a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /
587 $ d12 )
588 20 CONTINUE
589 END IF
590*
591* Copy diagonal elements of D(K) to A,
592* copy superdiagonal element of D(K) to E(K) and
593* ZERO out superdiagonal entry of A
594*
595 a( k-1, k-1 ) = w( k-1, kw-1 )
596 a( k-1, k ) = czero
597 a( k, k ) = w( k, kw )
598 e( k ) = w( k-1, kw )
599 e( k-1 ) = czero
600*
601 END IF
602*
603* End column K is nonsingular
604*
605 END IF
606*
607* Store details of the interchanges in IPIV
608*
609 IF( kstep.EQ.1 ) THEN
610 ipiv( k ) = kp
611 ELSE
612 ipiv( k ) = -p
613 ipiv( k-1 ) = -kp
614 END IF
615*
616* Decrease K and return to the start of the main loop
617*
618 k = k - kstep
619 GO TO 10
620*
621 30 CONTINUE
622*
623* Update the upper triangle of A11 (= A(1:k,1:k)) as
624*
625* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
626*
627* computing blocks of NB columns at a time
628*
629 DO 50 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
630 jb = min( nb, k-j+1 )
631*
632* Update the upper triangle of the diagonal block
633*
634 DO 40 jj = j, j + jb - 1
635 CALL cgemv( 'No transpose', jj-j+1, n-k, -cone,
636 $ a( j, k+1 ), lda, w( jj, kw+1 ), ldw, cone,
637 $ a( j, jj ), 1 )
638 40 CONTINUE
639*
640* Update the rectangular superdiagonal block
641*
642 IF( j.GE.2 )
643 $ CALL cgemm( 'No transpose', 'Transpose', j-1, jb,
644 $ n-k, -cone, a( 1, k+1 ), lda, w( j, kw+1 ),
645 $ ldw, cone, a( 1, j ), lda )
646 50 CONTINUE
647*
648* Set KB to the number of columns factorized
649*
650 kb = n - k
651*
652 ELSE
653*
654* Factorize the leading columns of A using the lower triangle
655* of A and working forwards, and compute the matrix W = L21*D
656* for use in updating A22
657*
658* Initialize the unused last entry of the subdiagonal array E.
659*
660 e( n ) = czero
661*
662* K is the main loop index, increasing from 1 in steps of 1 or 2
663*
664 k = 1
665 70 CONTINUE
666*
667* Exit from loop
668*
669 IF( ( k.GE.nb .AND. nb.LT.n ) .OR. k.GT.n )
670 $ GO TO 90
671*
672 kstep = 1
673 p = k
674*
675* Copy column K of A to column K of W and update it
676*
677 CALL ccopy( n-k+1, a( k, k ), 1, w( k, k ), 1 )
678 IF( k.GT.1 )
679 $ CALL cgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ),
680 $ lda, w( k, 1 ), ldw, cone, w( k, k ), 1 )
681*
682* Determine rows and columns to be interchanged and whether
683* a 1-by-1 or 2-by-2 pivot block will be used
684*
685 absakk = cabs1( w( k, k ) )
686*
687* IMAX is the row-index of the largest off-diagonal element in
688* column K, and COLMAX is its absolute value.
689* Determine both COLMAX and IMAX.
690*
691 IF( k.LT.n ) THEN
692 imax = k + icamax( n-k, w( k+1, k ), 1 )
693 colmax = cabs1( w( imax, k ) )
694 ELSE
695 colmax = zero
696 END IF
697*
698 IF( max( absakk, colmax ).EQ.zero ) THEN
699*
700* Column K is zero or underflow: set INFO and continue
701*
702 IF( info.EQ.0 )
703 $ info = k
704 kp = k
705 CALL ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
706*
707* Set E( K ) to zero
708*
709 IF( k.LT.n )
710 $ e( k ) = czero
711*
712 ELSE
713*
714* ============================================================
715*
716* Test for interchange
717*
718* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
719* (used to handle NaN and Inf)
720*
721 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
722*
723* no interchange, use 1-by-1 pivot block
724*
725 kp = k
726*
727 ELSE
728*
729 done = .false.
730*
731* Loop until pivot found
732*
733 72 CONTINUE
734*
735* Begin pivot search loop body
736*
737*
738* Copy column IMAX to column K+1 of W and update it
739*
740 CALL ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1)
741 CALL ccopy( n-imax+1, a( imax, imax ), 1,
742 $ w( imax, k+1 ), 1 )
743 IF( k.GT.1 )
744 $ CALL cgemv( 'No transpose', n-k+1, k-1, -cone,
745 $ a( k, 1 ), lda, w( imax, 1 ), ldw,
746 $ cone, w( k, k+1 ), 1 )
747*
748* JMAX is the column-index of the largest off-diagonal
749* element in row IMAX, and ROWMAX is its absolute value.
750* Determine both ROWMAX and JMAX.
751*
752 IF( imax.NE.k ) THEN
753 jmax = k - 1 + icamax( imax-k, w( k, k+1 ), 1 )
754 rowmax = cabs1( w( jmax, k+1 ) )
755 ELSE
756 rowmax = zero
757 END IF
758*
759 IF( imax.LT.n ) THEN
760 itemp = imax + icamax( n-imax, w( imax+1, k+1 ), 1)
761 stemp = cabs1( w( itemp, k+1 ) )
762 IF( stemp.GT.rowmax ) THEN
763 rowmax = stemp
764 jmax = itemp
765 END IF
766 END IF
767*
768* Equivalent to testing for
769* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
770* (used to handle NaN and Inf)
771*
772 IF( .NOT.( cabs1( w( imax, k+1 ) ).LT.alpha*rowmax ) )
773 $ THEN
774*
775* interchange rows and columns K and IMAX,
776* use 1-by-1 pivot block
777*
778 kp = imax
779*
780* copy column K+1 of W to column K of W
781*
782 CALL ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
783*
784 done = .true.
785*
786* Equivalent to testing for ROWMAX.EQ.COLMAX,
787* (used to handle NaN and Inf)
788*
789 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
790 $ THEN
791*
792* interchange rows and columns K+1 and IMAX,
793* use 2-by-2 pivot block
794*
795 kp = imax
796 kstep = 2
797 done = .true.
798 ELSE
799*
800* Pivot not found: set params and repeat
801*
802 p = imax
803 colmax = rowmax
804 imax = jmax
805*
806* Copy updated JMAXth (next IMAXth) column to Kth of W
807*
808 CALL ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
809*
810 END IF
811*
812* End pivot search loop body
813*
814 IF( .NOT. done ) GOTO 72
815*
816 END IF
817*
818* ============================================================
819*
820 kk = k + kstep - 1
821*
822 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
823*
824* Copy non-updated column K to column P
825*
826 CALL ccopy( p-k, a( k, k ), 1, a( p, k ), lda )
827 CALL ccopy( n-p+1, a( p, k ), 1, a( p, p ), 1 )
828*
829* Interchange rows K and P in first K columns of A
830* and first K+1 columns of W
831*
832 CALL cswap( k, a( k, 1 ), lda, a( p, 1 ), lda )
833 CALL cswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw )
834 END IF
835*
836* Updated column KP is already stored in column KK of W
837*
838 IF( kp.NE.kk ) THEN
839*
840* Copy non-updated column KK to column KP
841*
842 a( kp, k ) = a( kk, k )
843 CALL ccopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda )
844 CALL ccopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 )
845*
846* Interchange rows KK and KP in first KK columns of A and W
847*
848 CALL cswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda )
849 CALL cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw )
850 END IF
851*
852 IF( kstep.EQ.1 ) THEN
853*
854* 1-by-1 pivot block D(k): column k of W now holds
855*
856* W(k) = L(k)*D(k)
857*
858* where L(k) is the k-th column of L
859*
860* Store L(k) in column k of A
861*
862 CALL ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
863 IF( k.LT.n ) THEN
864 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
865 r1 = cone / a( k, k )
866 CALL cscal( n-k, r1, a( k+1, k ), 1 )
867 ELSE IF( a( k, k ).NE.czero ) THEN
868 DO 74 ii = k + 1, n
869 a( ii, k ) = a( ii, k ) / a( k, k )
870 74 CONTINUE
871 END IF
872*
873* Store the subdiagonal element of D in array E
874*
875 e( k ) = czero
876*
877 END IF
878*
879 ELSE
880*
881* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
882*
883* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
884*
885* where L(k) and L(k+1) are the k-th and (k+1)-th columns
886* of L
887*
888 IF( k.LT.n-1 ) THEN
889*
890* Store L(k) and L(k+1) in columns k and k+1 of A
891*
892 d21 = w( k+1, k )
893 d11 = w( k+1, k+1 ) / d21
894 d22 = w( k, k ) / d21
895 t = cone / ( d11*d22-cone )
896 DO 80 j = k + 2, n
897 a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /
898 $ d21 )
899 a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /
900 $ d21 )
901 80 CONTINUE
902 END IF
903*
904* Copy diagonal elements of D(K) to A,
905* copy subdiagonal element of D(K) to E(K) and
906* ZERO out subdiagonal entry of A
907*
908 a( k, k ) = w( k, k )
909 a( k+1, k ) = czero
910 a( k+1, k+1 ) = w( k+1, k+1 )
911 e( k ) = w( k+1, k )
912 e( k+1 ) = czero
913*
914 END IF
915*
916* End column K is nonsingular
917*
918 END IF
919*
920* Store details of the interchanges in IPIV
921*
922 IF( kstep.EQ.1 ) THEN
923 ipiv( k ) = kp
924 ELSE
925 ipiv( k ) = -p
926 ipiv( k+1 ) = -kp
927 END IF
928*
929* Increase K and return to the start of the main loop
930*
931 k = k + kstep
932 GO TO 70
933*
934 90 CONTINUE
935*
936* Update the lower triangle of A22 (= A(k:n,k:n)) as
937*
938* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
939*
940* computing blocks of NB columns at a time
941*
942 DO 110 j = k, n, nb
943 jb = min( nb, n-j+1 )
944*
945* Update the lower triangle of the diagonal block
946*
947 DO 100 jj = j, j + jb - 1
948 CALL cgemv( 'No transpose', j+jb-jj, k-1, -cone,
949 $ a( jj, 1 ), lda, w( jj, 1 ), ldw, cone,
950 $ a( jj, jj ), 1 )
951 100 CONTINUE
952*
953* Update the rectangular subdiagonal block
954*
955 IF( j+jb.LE.n )
956 $ CALL cgemm( 'No transpose', 'Transpose', n-j-jb+1, jb,
957 $ k-1, -cone, a( j+jb, 1 ), lda, w( j, 1 ),
958 $ ldw, cone, a( j+jb, j ), lda )
959 110 CONTINUE
960*
961* Set KB to the number of columns factorized
962*
963 kb = k - 1
964*
965 END IF
966*
967 RETURN
968*
969* End of CLASYF_RK
970*

◆ clasyf_rook()

subroutine clasyf_rook ( character uplo,
integer n,
integer nb,
integer kb,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldw, * ) w,
integer ldw,
integer info )

CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.

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

Purpose:
!>
!> CLASYF_ROOK computes a partial factorization of a complex symmetric
!> matrix A using the bounded Bunch-Kaufman () diagonal
!> pivoting method. The partial factorization has the form:
!>
!> A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
!>       ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
!>
!> A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
!>       ( L21  I ) (  0  A22 ) (  0       I    )
!>
!> where the order of D is at most NB. The actual order is returned in
!> the argument KB, and is either NB or NB-1, or N if N <= NB.
!>
!> CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses
!> blocked code (calling Level 3 BLAS) to update the submatrix
!> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The maximum number of columns of the matrix A that should be
!>          factored.  NB should be at least 2 to allow for 2-by-2 pivot
!>          blocks.
!>
[out]KB
!>          KB is INTEGER
!>          The number of columns of A that were actually factored.
!>          KB is either NB-1 or NB, or N if N <= NB.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, A contains details of the partial factorization.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>
!>          If UPLO = 'U':
!>             Only the last KB elements of IPIV are set.
!>
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>             interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
!>             columns k and -IPIV(k) were interchanged and rows and
!>             columns k-1 and -IPIV(k-1) were inerchaged,
!>             D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>             Only the first KB elements of IPIV are set.
!>
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>             were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
!>             columns k and -IPIV(k) were interchanged and rows and
!>             columns k+1 and -IPIV(k+1) were inerchaged,
!>             D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]W
!>          W is COMPLEX array, dimension (LDW,NB)
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array W.  LDW >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
!>               has been completed, but the block diagonal matrix D is
!>               exactly singular.
!>
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 182 of file clasyf_rook.f.

184*
185* -- LAPACK computational routine --
186* -- LAPACK is a software package provided by Univ. of Tennessee, --
187* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
188*
189* .. Scalar Arguments ..
190 CHARACTER UPLO
191 INTEGER INFO, KB, LDA, LDW, N, NB
192* ..
193* .. Array Arguments ..
194 INTEGER IPIV( * )
195 COMPLEX A( LDA, * ), W( LDW, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 REAL ZERO, ONE
202 parameter( zero = 0.0e+0, one = 1.0e+0 )
203 REAL EIGHT, SEVTEN
204 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
205 COMPLEX CONE, CZERO
206 parameter( cone = ( 1.0e+0, 0.0e+0 ),
207 $ czero = ( 0.0e+0, 0.0e+0 ) )
208* ..
209* .. Local Scalars ..
210 LOGICAL DONE
211 INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK,
212 $ KW, KKW, KP, KSTEP, P, II
213 REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
214 COMPLEX D11, D12, D21, D22, R1, T, Z
215* ..
216* .. External Functions ..
217 LOGICAL LSAME
218 INTEGER ICAMAX
219 REAL SLAMCH
220 EXTERNAL lsame, icamax, slamch
221* ..
222* .. External Subroutines ..
223 EXTERNAL ccopy, cgemm, cgemv, cscal, cswap
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC abs, max, min, sqrt, aimag, real
227* ..
228* .. Statement Functions ..
229 REAL CABS1
230* ..
231* .. Statement Function definitions ..
232 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
233* ..
234* .. Executable Statements ..
235*
236 info = 0
237*
238* Initialize ALPHA for use in choosing pivot block size.
239*
240 alpha = ( one+sqrt( sevten ) ) / eight
241*
242* Compute machine safe minimum
243*
244 sfmin = slamch( 'S' )
245*
246 IF( lsame( uplo, 'U' ) ) THEN
247*
248* Factorize the trailing columns of A using the upper triangle
249* of A and working backwards, and compute the matrix W = U12*D
250* for use in updating A11
251*
252* K is the main loop index, decreasing from N in steps of 1 or 2
253*
254 k = n
255 10 CONTINUE
256*
257* KW is the column of W which corresponds to column K of A
258*
259 kw = nb + k - n
260*
261* Exit from loop
262*
263 IF( ( k.LE.n-nb+1 .AND. nb.LT.n ) .OR. k.LT.1 )
264 $ GO TO 30
265*
266 kstep = 1
267 p = k
268*
269* Copy column K of A to column KW of W and update it
270*
271 CALL ccopy( k, a( 1, k ), 1, w( 1, kw ), 1 )
272 IF( k.LT.n )
273 $ CALL cgemv( 'No transpose', k, n-k, -cone, a( 1, k+1 ),
274 $ lda, w( k, kw+1 ), ldw, cone, w( 1, kw ), 1 )
275*
276* Determine rows and columns to be interchanged and whether
277* a 1-by-1 or 2-by-2 pivot block will be used
278*
279 absakk = cabs1( w( k, kw ) )
280*
281* IMAX is the row-index of the largest off-diagonal element in
282* column K, and COLMAX is its absolute value.
283* Determine both COLMAX and IMAX.
284*
285 IF( k.GT.1 ) THEN
286 imax = icamax( k-1, w( 1, kw ), 1 )
287 colmax = cabs1( w( imax, kw ) )
288 ELSE
289 colmax = zero
290 END IF
291*
292 IF( max( absakk, colmax ).EQ.zero ) THEN
293*
294* Column K is zero or underflow: set INFO and continue
295*
296 IF( info.EQ.0 )
297 $ info = k
298 kp = k
299 CALL ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
300 ELSE
301*
302* ============================================================
303*
304* Test for interchange
305*
306* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
307* (used to handle NaN and Inf)
308*
309 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
310*
311* no interchange, use 1-by-1 pivot block
312*
313 kp = k
314*
315 ELSE
316*
317 done = .false.
318*
319* Loop until pivot found
320*
321 12 CONTINUE
322*
323* Begin pivot search loop body
324*
325*
326* Copy column IMAX to column KW-1 of W and update it
327*
328 CALL ccopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 )
329 CALL ccopy( k-imax, a( imax, imax+1 ), lda,
330 $ w( imax+1, kw-1 ), 1 )
331*
332 IF( k.LT.n )
333 $ CALL cgemv( 'No transpose', k, n-k, -cone,
334 $ a( 1, k+1 ), lda, w( imax, kw+1 ), ldw,
335 $ cone, w( 1, kw-1 ), 1 )
336*
337* JMAX is the column-index of the largest off-diagonal
338* element in row IMAX, and ROWMAX is its absolute value.
339* Determine both ROWMAX and JMAX.
340*
341 IF( imax.NE.k ) THEN
342 jmax = imax + icamax( k-imax, w( imax+1, kw-1 ),
343 $ 1 )
344 rowmax = cabs1( w( jmax, kw-1 ) )
345 ELSE
346 rowmax = zero
347 END IF
348*
349 IF( imax.GT.1 ) THEN
350 itemp = icamax( imax-1, w( 1, kw-1 ), 1 )
351 stemp = cabs1( w( itemp, kw-1 ) )
352 IF( stemp.GT.rowmax ) THEN
353 rowmax = stemp
354 jmax = itemp
355 END IF
356 END IF
357*
358* Equivalent to testing for
359* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
360* (used to handle NaN and Inf)
361*
362 IF( .NOT.(cabs1( w( imax, kw-1 ) ).LT.alpha*rowmax ) )
363 $ THEN
364*
365* interchange rows and columns K and IMAX,
366* use 1-by-1 pivot block
367*
368 kp = imax
369*
370* copy column KW-1 of W to column KW of W
371*
372 CALL ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
373*
374 done = .true.
375*
376* Equivalent to testing for ROWMAX.EQ.COLMAX,
377* (used to handle NaN and Inf)
378*
379 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
380 $ THEN
381*
382* interchange rows and columns K-1 and IMAX,
383* use 2-by-2 pivot block
384*
385 kp = imax
386 kstep = 2
387 done = .true.
388 ELSE
389*
390* Pivot not found: set params and repeat
391*
392 p = imax
393 colmax = rowmax
394 imax = jmax
395*
396* Copy updated JMAXth (next IMAXth) column to Kth of W
397*
398 CALL ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
399*
400 END IF
401*
402* End pivot search loop body
403*
404 IF( .NOT. done ) GOTO 12
405*
406 END IF
407*
408* ============================================================
409*
410 kk = k - kstep + 1
411*
412* KKW is the column of W which corresponds to column KK of A
413*
414 kkw = nb + kk - n
415*
416 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
417*
418* Copy non-updated column K to column P
419*
420 CALL ccopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda )
421 CALL ccopy( p, a( 1, k ), 1, a( 1, p ), 1 )
422*
423* Interchange rows K and P in last N-K+1 columns of A
424* and last N-K+2 columns of W
425*
426 CALL cswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
427 CALL cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
428 END IF
429*
430* Updated column KP is already stored in column KKW of W
431*
432 IF( kp.NE.kk ) THEN
433*
434* Copy non-updated column KK to column KP
435*
436 a( kp, k ) = a( kk, k )
437 CALL ccopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
438 $ lda )
439 CALL ccopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 )
440*
441* Interchange rows KK and KP in last N-KK+1 columns
442* of A and W
443*
444 CALL cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
445 CALL cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),
446 $ ldw )
447 END IF
448*
449 IF( kstep.EQ.1 ) THEN
450*
451* 1-by-1 pivot block D(k): column KW of W now holds
452*
453* W(k) = U(k)*D(k)
454*
455* where U(k) is the k-th column of U
456*
457* Store U(k) in column k of A
458*
459 CALL ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
460 IF( k.GT.1 ) THEN
461 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
462 r1 = cone / a( k, k )
463 CALL cscal( k-1, r1, a( 1, k ), 1 )
464 ELSE IF( a( k, k ).NE.czero ) THEN
465 DO 14 ii = 1, k - 1
466 a( ii, k ) = a( ii, k ) / a( k, k )
467 14 CONTINUE
468 END IF
469 END IF
470*
471 ELSE
472*
473* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
474* hold
475*
476* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
477*
478* where U(k) and U(k-1) are the k-th and (k-1)-th columns
479* of U
480*
481 IF( k.GT.2 ) THEN
482*
483* Store U(k) and U(k-1) in columns k and k-1 of A
484*
485 d12 = w( k-1, kw )
486 d11 = w( k, kw ) / d12
487 d22 = w( k-1, kw-1 ) / d12
488 t = cone / ( d11*d22-cone )
489 DO 20 j = 1, k - 2
490 a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /
491 $ d12 )
492 a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /
493 $ d12 )
494 20 CONTINUE
495 END IF
496*
497* Copy D(k) to A
498*
499 a( k-1, k-1 ) = w( k-1, kw-1 )
500 a( k-1, k ) = w( k-1, kw )
501 a( k, k ) = w( k, kw )
502 END IF
503 END IF
504*
505* Store details of the interchanges in IPIV
506*
507 IF( kstep.EQ.1 ) THEN
508 ipiv( k ) = kp
509 ELSE
510 ipiv( k ) = -p
511 ipiv( k-1 ) = -kp
512 END IF
513*
514* Decrease K and return to the start of the main loop
515*
516 k = k - kstep
517 GO TO 10
518*
519 30 CONTINUE
520*
521* Update the upper triangle of A11 (= A(1:k,1:k)) as
522*
523* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
524*
525* computing blocks of NB columns at a time
526*
527 DO 50 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
528 jb = min( nb, k-j+1 )
529*
530* Update the upper triangle of the diagonal block
531*
532 DO 40 jj = j, j + jb - 1
533 CALL cgemv( 'No transpose', jj-j+1, n-k, -cone,
534 $ a( j, k+1 ), lda, w( jj, kw+1 ), ldw, cone,
535 $ a( j, jj ), 1 )
536 40 CONTINUE
537*
538* Update the rectangular superdiagonal block
539*
540 IF( j.GE.2 )
541 $ CALL cgemm( 'No transpose', 'Transpose', j-1, jb,
542 $ n-k, -cone, a( 1, k+1 ), lda, w( j, kw+1 ), ldw,
543 $ cone, a( 1, j ), lda )
544 50 CONTINUE
545*
546* Put U12 in standard form by partially undoing the interchanges
547* in columns k+1:n
548*
549 j = k + 1
550 60 CONTINUE
551*
552 kstep = 1
553 jp1 = 1
554 jj = j
555 jp2 = ipiv( j )
556 IF( jp2.LT.0 ) THEN
557 jp2 = -jp2
558 j = j + 1
559 jp1 = -ipiv( j )
560 kstep = 2
561 END IF
562*
563 j = j + 1
564 IF( jp2.NE.jj .AND. j.LE.n )
565 $ CALL cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), lda )
566 jj = j - 1
567 IF( jp1.NE.jj .AND. kstep.EQ.2 )
568 $ CALL cswap( n-j+1, a( jp1, j ), lda, a( jj, j ), lda )
569 IF( j.LE.n )
570 $ GO TO 60
571*
572* Set KB to the number of columns factorized
573*
574 kb = n - k
575*
576 ELSE
577*
578* Factorize the leading columns of A using the lower triangle
579* of A and working forwards, and compute the matrix W = L21*D
580* for use in updating A22
581*
582* K is the main loop index, increasing from 1 in steps of 1 or 2
583*
584 k = 1
585 70 CONTINUE
586*
587* Exit from loop
588*
589 IF( ( k.GE.nb .AND. nb.LT.n ) .OR. k.GT.n )
590 $ GO TO 90
591*
592 kstep = 1
593 p = k
594*
595* Copy column K of A to column K of W and update it
596*
597 CALL ccopy( n-k+1, a( k, k ), 1, w( k, k ), 1 )
598 IF( k.GT.1 )
599 $ CALL cgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ),
600 $ lda, w( k, 1 ), ldw, cone, w( k, k ), 1 )
601*
602* Determine rows and columns to be interchanged and whether
603* a 1-by-1 or 2-by-2 pivot block will be used
604*
605 absakk = cabs1( w( k, k ) )
606*
607* IMAX is the row-index of the largest off-diagonal element in
608* column K, and COLMAX is its absolute value.
609* Determine both COLMAX and IMAX.
610*
611 IF( k.LT.n ) THEN
612 imax = k + icamax( n-k, w( k+1, k ), 1 )
613 colmax = cabs1( w( imax, k ) )
614 ELSE
615 colmax = zero
616 END IF
617*
618 IF( max( absakk, colmax ).EQ.zero ) THEN
619*
620* Column K is zero or underflow: set INFO and continue
621*
622 IF( info.EQ.0 )
623 $ info = k
624 kp = k
625 CALL ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
626 ELSE
627*
628* ============================================================
629*
630* Test for interchange
631*
632* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
633* (used to handle NaN and Inf)
634*
635 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
636*
637* no interchange, use 1-by-1 pivot block
638*
639 kp = k
640*
641 ELSE
642*
643 done = .false.
644*
645* Loop until pivot found
646*
647 72 CONTINUE
648*
649* Begin pivot search loop body
650*
651*
652* Copy column IMAX to column K+1 of W and update it
653*
654 CALL ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1)
655 CALL ccopy( n-imax+1, a( imax, imax ), 1,
656 $ w( imax, k+1 ), 1 )
657 IF( k.GT.1 )
658 $ CALL cgemv( 'No transpose', n-k+1, k-1, -cone,
659 $ a( k, 1 ), lda, w( imax, 1 ), ldw,
660 $ cone, w( k, k+1 ), 1 )
661*
662* JMAX is the column-index of the largest off-diagonal
663* element in row IMAX, and ROWMAX is its absolute value.
664* Determine both ROWMAX and JMAX.
665*
666 IF( imax.NE.k ) THEN
667 jmax = k - 1 + icamax( imax-k, w( k, k+1 ), 1 )
668 rowmax = cabs1( w( jmax, k+1 ) )
669 ELSE
670 rowmax = zero
671 END IF
672*
673 IF( imax.LT.n ) THEN
674 itemp = imax + icamax( n-imax, w( imax+1, k+1 ), 1)
675 stemp = cabs1( w( itemp, k+1 ) )
676 IF( stemp.GT.rowmax ) THEN
677 rowmax = stemp
678 jmax = itemp
679 END IF
680 END IF
681*
682* Equivalent to testing for
683* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
684* (used to handle NaN and Inf)
685*
686 IF( .NOT.( cabs1( w( imax, k+1 ) ).LT.alpha*rowmax ) )
687 $ THEN
688*
689* interchange rows and columns K and IMAX,
690* use 1-by-1 pivot block
691*
692 kp = imax
693*
694* copy column K+1 of W to column K of W
695*
696 CALL ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
697*
698 done = .true.
699*
700* Equivalent to testing for ROWMAX.EQ.COLMAX,
701* (used to handle NaN and Inf)
702*
703 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
704 $ THEN
705*
706* interchange rows and columns K+1 and IMAX,
707* use 2-by-2 pivot block
708*
709 kp = imax
710 kstep = 2
711 done = .true.
712 ELSE
713*
714* Pivot not found: set params and repeat
715*
716 p = imax
717 colmax = rowmax
718 imax = jmax
719*
720* Copy updated JMAXth (next IMAXth) column to Kth of W
721*
722 CALL ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
723*
724 END IF
725*
726* End pivot search loop body
727*
728 IF( .NOT. done ) GOTO 72
729*
730 END IF
731*
732* ============================================================
733*
734 kk = k + kstep - 1
735*
736 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
737*
738* Copy non-updated column K to column P
739*
740 CALL ccopy( p-k, a( k, k ), 1, a( p, k ), lda )
741 CALL ccopy( n-p+1, a( p, k ), 1, a( p, p ), 1 )
742*
743* Interchange rows K and P in first K columns of A
744* and first K+1 columns of W
745*
746 CALL cswap( k, a( k, 1 ), lda, a( p, 1 ), lda )
747 CALL cswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw )
748 END IF
749*
750* Updated column KP is already stored in column KK of W
751*
752 IF( kp.NE.kk ) THEN
753*
754* Copy non-updated column KK to column KP
755*
756 a( kp, k ) = a( kk, k )
757 CALL ccopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda )
758 CALL ccopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 )
759*
760* Interchange rows KK and KP in first KK columns of A and W
761*
762 CALL cswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda )
763 CALL cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw )
764 END IF
765*
766 IF( kstep.EQ.1 ) THEN
767*
768* 1-by-1 pivot block D(k): column k of W now holds
769*
770* W(k) = L(k)*D(k)
771*
772* where L(k) is the k-th column of L
773*
774* Store L(k) in column k of A
775*
776 CALL ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
777 IF( k.LT.n ) THEN
778 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
779 r1 = cone / a( k, k )
780 CALL cscal( n-k, r1, a( k+1, k ), 1 )
781 ELSE IF( a( k, k ).NE.czero ) THEN
782 DO 74 ii = k + 1, n
783 a( ii, k ) = a( ii, k ) / a( k, k )
784 74 CONTINUE
785 END IF
786 END IF
787*
788 ELSE
789*
790* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
791*
792* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
793*
794* where L(k) and L(k+1) are the k-th and (k+1)-th columns
795* of L
796*
797 IF( k.LT.n-1 ) THEN
798*
799* Store L(k) and L(k+1) in columns k and k+1 of A
800*
801 d21 = w( k+1, k )
802 d11 = w( k+1, k+1 ) / d21
803 d22 = w( k, k ) / d21
804 t = cone / ( d11*d22-cone )
805 DO 80 j = k + 2, n
806 a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /
807 $ d21 )
808 a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /
809 $ d21 )
810 80 CONTINUE
811 END IF
812*
813* Copy D(k) to A
814*
815 a( k, k ) = w( k, k )
816 a( k+1, k ) = w( k+1, k )
817 a( k+1, k+1 ) = w( k+1, k+1 )
818 END IF
819 END IF
820*
821* Store details of the interchanges in IPIV
822*
823 IF( kstep.EQ.1 ) THEN
824 ipiv( k ) = kp
825 ELSE
826 ipiv( k ) = -p
827 ipiv( k+1 ) = -kp
828 END IF
829*
830* Increase K and return to the start of the main loop
831*
832 k = k + kstep
833 GO TO 70
834*
835 90 CONTINUE
836*
837* Update the lower triangle of A22 (= A(k:n,k:n)) as
838*
839* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
840*
841* computing blocks of NB columns at a time
842*
843 DO 110 j = k, n, nb
844 jb = min( nb, n-j+1 )
845*
846* Update the lower triangle of the diagonal block
847*
848 DO 100 jj = j, j + jb - 1
849 CALL cgemv( 'No transpose', j+jb-jj, k-1, -cone,
850 $ a( jj, 1 ), lda, w( jj, 1 ), ldw, cone,
851 $ a( jj, jj ), 1 )
852 100 CONTINUE
853*
854* Update the rectangular subdiagonal block
855*
856 IF( j+jb.LE.n )
857 $ CALL cgemm( 'No transpose', 'Transpose', n-j-jb+1, jb,
858 $ k-1, -cone, a( j+jb, 1 ), lda, w( j, 1 ), ldw,
859 $ cone, a( j+jb, j ), lda )
860 110 CONTINUE
861*
862* Put L21 in standard form by partially undoing the interchanges
863* in columns 1:k-1
864*
865 j = k - 1
866 120 CONTINUE
867*
868 kstep = 1
869 jp1 = 1
870 jj = j
871 jp2 = ipiv( j )
872 IF( jp2.LT.0 ) THEN
873 jp2 = -jp2
874 j = j - 1
875 jp1 = -ipiv( j )
876 kstep = 2
877 END IF
878*
879 j = j - 1
880 IF( jp2.NE.jj .AND. j.GE.1 )
881 $ CALL cswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda )
882 jj = j + 1
883 IF( jp1.NE.jj .AND. kstep.EQ.2 )
884 $ CALL cswap( j, a( jp1, 1 ), lda, a( jj, 1 ), lda )
885 IF( j.GE.1 )
886 $ GO TO 120
887*
888* Set KB to the number of columns factorized
889*
890 kb = k - 1
891*
892 END IF
893 RETURN
894*
895* End of CLASYF_ROOK
896*

◆ csycon()

subroutine csycon ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
real anorm,
real rcond,
complex, dimension( * ) work,
integer info )

CSYCON

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

Purpose:
!>
!> CSYCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex symmetric matrix A using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by CSYTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF.
!>
[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 CSYTRF.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file csycon.f.

125*
126* -- LAPACK computational routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 CHARACTER UPLO
132 INTEGER INFO, LDA, N
133 REAL ANORM, RCOND
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 COMPLEX A( LDA, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ONE, ZERO
144 parameter( one = 1.0e+0, zero = 0.0e+0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER I, KASE
149 REAL AINVNM
150* ..
151* .. Local Arrays ..
152 INTEGER ISAVE( 3 )
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 EXTERNAL lsame
157* ..
158* .. External Subroutines ..
159 EXTERNAL clacn2, csytrs, xerbla
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max
163* ..
164* .. Executable Statements ..
165*
166* Test the input parameters.
167*
168 info = 0
169 upper = lsame( uplo, 'U' )
170 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
171 info = -1
172 ELSE IF( n.LT.0 ) THEN
173 info = -2
174 ELSE IF( lda.LT.max( 1, n ) ) THEN
175 info = -4
176 ELSE IF( anorm.LT.zero ) THEN
177 info = -6
178 END IF
179 IF( info.NE.0 ) THEN
180 CALL xerbla( 'CSYCON', -info )
181 RETURN
182 END IF
183*
184* Quick return if possible
185*
186 rcond = zero
187 IF( n.EQ.0 ) THEN
188 rcond = one
189 RETURN
190 ELSE IF( anorm.LE.zero ) THEN
191 RETURN
192 END IF
193*
194* Check that the diagonal matrix D is nonsingular.
195*
196 IF( upper ) THEN
197*
198* Upper triangular storage: examine D from bottom to top
199*
200 DO 10 i = n, 1, -1
201 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
202 $ RETURN
203 10 CONTINUE
204 ELSE
205*
206* Lower triangular storage: examine D from top to bottom.
207*
208 DO 20 i = 1, n
209 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
210 $ RETURN
211 20 CONTINUE
212 END IF
213*
214* Estimate the 1-norm of the inverse.
215*
216 kase = 0
217 30 CONTINUE
218 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
219 IF( kase.NE.0 ) THEN
220*
221* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
222*
223 CALL csytrs( uplo, n, 1, a, lda, ipiv, work, n, info )
224 GO TO 30
225 END IF
226*
227* Compute the estimate of the reciprocal condition number.
228*
229 IF( ainvnm.NE.zero )
230 $ rcond = ( one / ainvnm ) / anorm
231*
232 RETURN
233*
234* End of CSYCON
235*

◆ csycon_3()

subroutine csycon_3 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
real anorm,
real rcond,
complex, dimension( * ) work,
integer info )

CSYCON_3

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

Purpose:
!> CSYCON_3 estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex symmetric matrix A using the factorization
!> computed by CSYTRF_RK or CSYTRF_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.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!> This routine uses BLAS3 solver CSYTRS_3.
!>
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 = P*U*D*(U**T)*(P**T);
!>          = 'L':  Lower triangular, form is A = P*L*D*(L**T)*(P**T).
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by CSYTRF_RK and CSYTRF_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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]E
!>          E is COMPLEX 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 referenced;
!>          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 CSYTRF_RK or CSYTRF_BK.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>  June 2017,  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 164 of file csycon_3.f.

166*
167* -- LAPACK computational routine --
168* -- LAPACK is a software package provided by Univ. of Tennessee, --
169* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170*
171* .. Scalar Arguments ..
172 CHARACTER UPLO
173 INTEGER INFO, LDA, N
174 REAL ANORM, RCOND
175* ..
176* .. Array Arguments ..
177 INTEGER IPIV( * )
178 COMPLEX A( LDA, * ), E( * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* .. Parameters ..
184 REAL ONE, ZERO
185 parameter( one = 1.0e+0, zero = 0.0e+0 )
186 COMPLEX CZERO
187 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
188* ..
189* .. Local Scalars ..
190 LOGICAL UPPER
191 INTEGER I, KASE
192 REAL AINVNM
193* ..
194* .. Local Arrays ..
195 INTEGER ISAVE( 3 )
196* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 EXTERNAL lsame
200* ..
201* .. External Subroutines ..
202 EXTERNAL clacn2, csytrs_3, xerbla
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC max
206* ..
207* .. Executable Statements ..
208*
209* Test the input parameters.
210*
211 info = 0
212 upper = lsame( uplo, 'U' )
213 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
214 info = -1
215 ELSE IF( n.LT.0 ) THEN
216 info = -2
217 ELSE IF( lda.LT.max( 1, n ) ) THEN
218 info = -4
219 ELSE IF( anorm.LT.zero ) THEN
220 info = -7
221 END IF
222 IF( info.NE.0 ) THEN
223 CALL xerbla( 'CSYCON_3', -info )
224 RETURN
225 END IF
226*
227* Quick return if possible
228*
229 rcond = zero
230 IF( n.EQ.0 ) THEN
231 rcond = one
232 RETURN
233 ELSE IF( anorm.LE.zero ) THEN
234 RETURN
235 END IF
236*
237* Check that the diagonal matrix D is nonsingular.
238*
239 IF( upper ) THEN
240*
241* Upper triangular storage: examine D from bottom to top
242*
243 DO i = n, 1, -1
244 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.czero )
245 $ RETURN
246 END DO
247 ELSE
248*
249* Lower triangular storage: examine D from top to bottom.
250*
251 DO i = 1, n
252 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.czero )
253 $ RETURN
254 END DO
255 END IF
256*
257* Estimate the 1-norm of the inverse.
258*
259 kase = 0
260 30 CONTINUE
261 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
262 IF( kase.NE.0 ) THEN
263*
264* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
265*
266 CALL csytrs_3( uplo, n, 1, a, lda, e, ipiv, work, n, info )
267 GO TO 30
268 END IF
269*
270* Compute the estimate of the reciprocal condition number.
271*
272 IF( ainvnm.NE.zero )
273 $ rcond = ( one / ainvnm ) / anorm
274*
275 RETURN
276*
277* End of CSYCON_3
278*
csytrs_3
subroutine csytrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
CSYTRS_3
Definition csytrs_3.f:165

◆ csycon_rook()

subroutine csycon_rook ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
real anorm,
real rcond,
complex, dimension( * ) work,
integer info )

CSYCON_ROOK

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

Purpose:
!>
!> CSYCON_ROOK estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex symmetric matrix A using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF_ROOK.
!>
[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 CSYTRF_ROOK.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>   April 2012, 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 137 of file csycon_rook.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 CHARACTER UPLO
146 INTEGER INFO, LDA, N
147 REAL ANORM, RCOND
148* ..
149* .. Array Arguments ..
150 INTEGER IPIV( * )
151 COMPLEX A( LDA, * ), WORK( * )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 REAL ONE, ZERO
158 parameter( one = 1.0e+0, zero = 0.0e+0 )
159 COMPLEX CZERO
160 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
161* ..
162* .. Local Scalars ..
163 LOGICAL UPPER
164 INTEGER I, KASE
165 REAL AINVNM
166* ..
167* .. Local Arrays ..
168 INTEGER ISAVE( 3 )
169* ..
170* .. External Functions ..
171 LOGICAL LSAME
172 EXTERNAL lsame
173* ..
174* .. External Subroutines ..
175 EXTERNAL clacn2, csytrs_rook, xerbla
176* ..
177* .. Intrinsic Functions ..
178 INTRINSIC max
179* ..
180* .. Executable Statements ..
181*
182* Test the input parameters.
183*
184 info = 0
185 upper = lsame( uplo, 'U' )
186 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
187 info = -1
188 ELSE IF( n.LT.0 ) THEN
189 info = -2
190 ELSE IF( lda.LT.max( 1, n ) ) THEN
191 info = -4
192 ELSE IF( anorm.LT.zero ) THEN
193 info = -6
194 END IF
195 IF( info.NE.0 ) THEN
196 CALL xerbla( 'CSYCON_ROOK', -info )
197 RETURN
198 END IF
199*
200* Quick return if possible
201*
202 rcond = zero
203 IF( n.EQ.0 ) THEN
204 rcond = one
205 RETURN
206 ELSE IF( anorm.LE.zero ) THEN
207 RETURN
208 END IF
209*
210* Check that the diagonal matrix D is nonsingular.
211*
212 IF( upper ) THEN
213*
214* Upper triangular storage: examine D from bottom to top
215*
216 DO 10 i = n, 1, -1
217 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.czero )
218 $ RETURN
219 10 CONTINUE
220 ELSE
221*
222* Lower triangular storage: examine D from top to bottom.
223*
224 DO 20 i = 1, n
225 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.czero )
226 $ RETURN
227 20 CONTINUE
228 END IF
229*
230* Estimate the 1-norm of the inverse.
231*
232 kase = 0
233 30 CONTINUE
234 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
235 IF( kase.NE.0 ) THEN
236*
237* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
238*
239 CALL csytrs_rook( uplo, n, 1, a, lda, ipiv, work, n, info )
240 GO TO 30
241 END IF
242*
243* Compute the estimate of the reciprocal condition number.
244*
245 IF( ainvnm.NE.zero )
246 $ rcond = ( one / ainvnm ) / anorm
247*
248 RETURN
249*
250* End of CSYCON_ROOK
251*
csytrs_rook
subroutine csytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CSYTRS_ROOK
Definition csytrs_rook.f:136

◆ csyconv()

subroutine csyconv ( character uplo,
character way,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( * ) e,
integer info )

CSYCONV

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

Purpose:
!>
!> CSYCONV convert A given by TRF into L and D and vice-versa.
!> Get Non-diag elements of D (returned in workspace) and
!> apply or reverse permutation done in TRF.
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]WAY
!>          WAY is CHARACTER*1
!>          = 'C': Convert
!>          = 'R': Revert
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF.
!>
[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 CSYTRF.
!>
[out]E
!>          E is COMPLEX array, dimension (N)
!>          E stores the supdiagonal/subdiagonal of the symmetric 1-by-1
!>          or 2-by-2 block diagonal matrix D in LDLT.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file csyconv.f.

114*
115* -- LAPACK computational routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 CHARACTER UPLO, WAY
121 INTEGER INFO, LDA, N
122* ..
123* .. Array Arguments ..
124 INTEGER IPIV( * )
125 COMPLEX A( LDA, * ), E( * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 COMPLEX ZERO
132 parameter( zero = (0.0e+0,0.0e+0) )
133* ..
134* .. External Functions ..
135 LOGICAL LSAME
136 EXTERNAL lsame
137*
138* .. External Subroutines ..
139 EXTERNAL xerbla
140* .. Local Scalars ..
141 LOGICAL UPPER, CONVERT
142 INTEGER I, IP, J
143 COMPLEX TEMP
144* ..
145* .. Executable Statements ..
146*
147 info = 0
148 upper = lsame( uplo, 'U' )
149 convert = lsame( way, 'C' )
150 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
151 info = -1
152 ELSE IF( .NOT.convert .AND. .NOT.lsame( way, 'R' ) ) THEN
153 info = -2
154 ELSE IF( n.LT.0 ) THEN
155 info = -3
156 ELSE IF( lda.LT.max( 1, n ) ) THEN
157 info = -5
158
159 END IF
160 IF( info.NE.0 ) THEN
161 CALL xerbla( 'CSYCONV', -info )
162 RETURN
163 END IF
164*
165* Quick return if possible
166*
167 IF( n.EQ.0 )
168 $ RETURN
169*
170 IF( upper ) THEN
171*
172* A is UPPER
173*
174* Convert A (A is upper)
175*
176* Convert VALUE
177*
178 IF ( convert ) THEN
179 i=n
180 e(1)=zero
181 DO WHILE ( i .GT. 1 )
182 IF( ipiv(i) .LT. 0 ) THEN
183 e(i)=a(i-1,i)
184 e(i-1)=zero
185 a(i-1,i)=zero
186 i=i-1
187 ELSE
188 e(i)=zero
189 ENDIF
190 i=i-1
191 END DO
192*
193* Convert PERMUTATIONS
194*
195 i=n
196 DO WHILE ( i .GE. 1 )
197 IF( ipiv(i) .GT. 0) THEN
198 ip=ipiv(i)
199 IF( i .LT. n) THEN
200 DO 12 j= i+1,n
201 temp=a(ip,j)
202 a(ip,j)=a(i,j)
203 a(i,j)=temp
204 12 CONTINUE
205 ENDIF
206 ELSE
207 ip=-ipiv(i)
208 IF( i .LT. n) THEN
209 DO 13 j= i+1,n
210 temp=a(ip,j)
211 a(ip,j)=a(i-1,j)
212 a(i-1,j)=temp
213 13 CONTINUE
214 ENDIF
215 i=i-1
216 ENDIF
217 i=i-1
218 END DO
219
220 ELSE
221*
222* Revert A (A is upper)
223*
224*
225* Revert PERMUTATIONS
226*
227 i=1
228 DO WHILE ( i .LE. n )
229 IF( ipiv(i) .GT. 0 ) THEN
230 ip=ipiv(i)
231 IF( i .LT. n) THEN
232 DO j= i+1,n
233 temp=a(ip,j)
234 a(ip,j)=a(i,j)
235 a(i,j)=temp
236 END DO
237 ENDIF
238 ELSE
239 ip=-ipiv(i)
240 i=i+1
241 IF( i .LT. n) THEN
242 DO j= i+1,n
243 temp=a(ip,j)
244 a(ip,j)=a(i-1,j)
245 a(i-1,j)=temp
246 END DO
247 ENDIF
248 ENDIF
249 i=i+1
250 END DO
251*
252* Revert VALUE
253*
254 i=n
255 DO WHILE ( i .GT. 1 )
256 IF( ipiv(i) .LT. 0 ) THEN
257 a(i-1,i)=e(i)
258 i=i-1
259 ENDIF
260 i=i-1
261 END DO
262 END IF
263 ELSE
264*
265* A is LOWER
266*
267 IF ( convert ) THEN
268*
269* Convert A (A is lower)
270*
271*
272* Convert VALUE
273*
274 i=1
275 e(n)=zero
276 DO WHILE ( i .LE. n )
277 IF( i.LT.n .AND. ipiv(i) .LT. 0 ) THEN
278 e(i)=a(i+1,i)
279 e(i+1)=zero
280 a(i+1,i)=zero
281 i=i+1
282 ELSE
283 e(i)=zero
284 ENDIF
285 i=i+1
286 END DO
287*
288* Convert PERMUTATIONS
289*
290 i=1
291 DO WHILE ( i .LE. n )
292 IF( ipiv(i) .GT. 0 ) THEN
293 ip=ipiv(i)
294 IF (i .GT. 1) THEN
295 DO 22 j= 1,i-1
296 temp=a(ip,j)
297 a(ip,j)=a(i,j)
298 a(i,j)=temp
299 22 CONTINUE
300 ENDIF
301 ELSE
302 ip=-ipiv(i)
303 IF (i .GT. 1) THEN
304 DO 23 j= 1,i-1
305 temp=a(ip,j)
306 a(ip,j)=a(i+1,j)
307 a(i+1,j)=temp
308 23 CONTINUE
309 ENDIF
310 i=i+1
311 ENDIF
312 i=i+1
313 END DO
314 ELSE
315*
316* Revert A (A is lower)
317*
318*
319* Revert PERMUTATIONS
320*
321 i=n
322 DO WHILE ( i .GE. 1 )
323 IF( ipiv(i) .GT. 0 ) THEN
324 ip=ipiv(i)
325 IF (i .GT. 1) THEN
326 DO j= 1,i-1
327 temp=a(i,j)
328 a(i,j)=a(ip,j)
329 a(ip,j)=temp
330 END DO
331 ENDIF
332 ELSE
333 ip=-ipiv(i)
334 i=i-1
335 IF (i .GT. 1) THEN
336 DO j= 1,i-1
337 temp=a(i+1,j)
338 a(i+1,j)=a(ip,j)
339 a(ip,j)=temp
340 END DO
341 ENDIF
342 ENDIF
343 i=i-1
344 END DO
345*
346* Revert VALUE
347*
348 i=1
349 DO WHILE ( i .LE. n-1 )
350 IF( ipiv(i) .LT. 0 ) THEN
351 a(i+1,i)=e(i)
352 i=i+1
353 ENDIF
354 i=i+1
355 END DO
356 END IF
357 END IF
358
359 RETURN
360*
361* End of CSYCONV
362*

◆ csyconvf()

subroutine csyconvf ( character uplo,
character way,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
integer info )

CSYCONVF

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

Purpose:
!> If parameter WAY = 'C':
!> CSYCONVF converts the factorization output format used in
!> CSYTRF provided on entry in parameter A into the factorization
!> output format used in CSYTRF_RK (or CSYTRF_BK) that is stored
!> on exit in parameters A and E. It also converts in place details of
!> the intechanges stored in IPIV from the format used in CSYTRF into
!> the format used in CSYTRF_RK (or CSYTRF_BK).
!>
!> If parameter WAY = 'R':
!> CSYCONVF performs the conversion in reverse direction, i.e.
!> converts the factorization output format used in CSYTRF_RK
!> (or CSYTRF_BK) provided on entry in parameters A and E into
!> the factorization output format used in CSYTRF that is stored
!> on exit in parameter A. It also converts in place details of
!> the intechanges stored in IPIV from the format used in CSYTRF_RK
!> (or CSYTRF_BK) into the format used in CSYTRF.
!>
!> CSYCONVF can also convert in Hermitian matrix case, i.e. between
!> formats used in CHETRF and CHETRF_RK (or CHETRF_BK).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are
!>          stored as an upper or lower triangular matrix A.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]WAY
!>          WAY is CHARACTER*1
!>          = 'C': Convert
!>          = 'R': Revert
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>
!>          1) If WAY ='C':
!>
!>          On entry, contains factorization details in format used in
!>          CSYTRF:
!>            a) all elements of the symmetric block diagonal
!>               matrix D on the diagonal of A and on superdiagonal
!>               (or subdiagonal) of A, and
!>            b) If UPLO = 'U': multipliers used to obtain factor U
!>               in the superdiagonal part of A.
!>               If UPLO = 'L': multipliers used to obtain factor L
!>               in the superdiagonal part of A.
!>
!>          On exit, contains factorization details in format used in
!>          CSYTRF_RK or CSYTRF_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
!>                are stored on exit 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.
!>
!>          2) If WAY = 'R':
!>
!>          On entry, contains factorization details in format used in
!>          CSYTRF_RK or CSYTRF_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
!>                are stored on exit 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, contains factorization details in format used in
!>          CSYTRF:
!>            a) all elements of the symmetric block diagonal
!>               matrix D on the diagonal of A and on superdiagonal
!>               (or subdiagonal) of A, and
!>            b) If UPLO = 'U': multipliers used to obtain factor U
!>               in the superdiagonal part of A.
!>               If UPLO = 'L': multipliers used to obtain factor L
!>               in the superdiagonal part of A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]E
!>          E is COMPLEX array, dimension (N)
!>
!>          1) If WAY ='C':
!>
!>          On entry, just a workspace.
!>
!>          On exit, 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) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          2) If WAY = 'R':
!>
!>          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 referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
!>          On exit, is not changed
!>
[in,out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>
!>          1) If WAY ='C':
!>          On entry, details of the interchanges and the block
!>          structure of D in the format used in CSYTRF.
!>          On exit, details of the interchanges and the block
!>          structure of D in the format used in CSYTRF_RK
!>          ( or CSYTRF_BK).
!>
!>          1) If WAY ='R':
!>          On entry, details of the interchanges and the block
!>          structure of D in the format used in CSYTRF_RK
!>          ( or CSYTRF_BK).
!>          On exit, details of the interchanges and the block
!>          structure of D in the format used in CSYTRF.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>  November 2017,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>

Definition at line 208 of file csyconvf.f.

209*
210* -- LAPACK computational routine --
211* -- LAPACK is a software package provided by Univ. of Tennessee, --
212* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
213*
214* .. Scalar Arguments ..
215 CHARACTER UPLO, WAY
216 INTEGER INFO, LDA, N
217* ..
218* .. Array Arguments ..
219 INTEGER IPIV( * )
220 COMPLEX A( LDA, * ), E( * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 COMPLEX ZERO
227 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
228* ..
229* .. External Functions ..
230 LOGICAL LSAME
231 EXTERNAL lsame
232*
233* .. External Subroutines ..
234 EXTERNAL cswap, xerbla
235* .. Local Scalars ..
236 LOGICAL UPPER, CONVERT
237 INTEGER I, IP
238* ..
239* .. Executable Statements ..
240*
241 info = 0
242 upper = lsame( uplo, 'U' )
243 convert = lsame( way, 'C' )
244 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
245 info = -1
246 ELSE IF( .NOT.convert .AND. .NOT.lsame( way, 'R' ) ) THEN
247 info = -2
248 ELSE IF( n.LT.0 ) THEN
249 info = -3
250 ELSE IF( lda.LT.max( 1, n ) ) THEN
251 info = -5
252
253 END IF
254 IF( info.NE.0 ) THEN
255 CALL xerbla( 'CSYCONVF', -info )
256 RETURN
257 END IF
258*
259* Quick return if possible
260*
261 IF( n.EQ.0 )
262 $ RETURN
263*
264 IF( upper ) THEN
265*
266* Begin A is UPPER
267*
268 IF ( convert ) THEN
269*
270* Convert A (A is upper)
271*
272*
273* Convert VALUE
274*
275* Assign superdiagonal entries of D to array E and zero out
276* corresponding entries in input storage A
277*
278 i = n
279 e( 1 ) = zero
280 DO WHILE ( i.GT.1 )
281 IF( ipiv( i ).LT.0 ) THEN
282 e( i ) = a( i-1, i )
283 e( i-1 ) = zero
284 a( i-1, i ) = zero
285 i = i - 1
286 ELSE
287 e( i ) = zero
288 END IF
289 i = i - 1
290 END DO
291*
292* Convert PERMUTATIONS and IPIV
293*
294* Apply permutations to submatrices of upper part of A
295* in factorization order where i decreases from N to 1
296*
297 i = n
298 DO WHILE ( i.GE.1 )
299 IF( ipiv( i ).GT.0 ) THEN
300*
301* 1-by-1 pivot interchange
302*
303* Swap rows i and IPIV(i) in A(1:i,N-i:N)
304*
305 ip = ipiv( i )
306 IF( i.LT.n ) THEN
307 IF( ip.NE.i ) THEN
308 CALL cswap( n-i, a( i, i+1 ), lda,
309 $ a( ip, i+1 ), lda )
310 END IF
311 END IF
312*
313 ELSE
314*
315* 2-by-2 pivot interchange
316*
317* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
318*
319 ip = -ipiv( i )
320 IF( i.LT.n ) THEN
321 IF( ip.NE.(i-1) ) THEN
322 CALL cswap( n-i, a( i-1, i+1 ), lda,
323 $ a( ip, i+1 ), lda )
324 END IF
325 END IF
326*
327* Convert IPIV
328* There is no interchnge of rows i and and IPIV(i),
329* so this should be reflected in IPIV format for
330* *SYTRF_RK ( or *SYTRF_BK)
331*
332 ipiv( i ) = i
333*
334 i = i - 1
335*
336 END IF
337 i = i - 1
338 END DO
339*
340 ELSE
341*
342* Revert A (A is upper)
343*
344*
345* Revert PERMUTATIONS and IPIV
346*
347* Apply permutations to submatrices of upper part of A
348* in reverse factorization order where i increases from 1 to N
349*
350 i = 1
351 DO WHILE ( i.LE.n )
352 IF( ipiv( i ).GT.0 ) THEN
353*
354* 1-by-1 pivot interchange
355*
356* Swap rows i and IPIV(i) in A(1:i,N-i:N)
357*
358 ip = ipiv( i )
359 IF( i.LT.n ) THEN
360 IF( ip.NE.i ) THEN
361 CALL cswap( n-i, a( ip, i+1 ), lda,
362 $ a( i, i+1 ), lda )
363 END IF
364 END IF
365*
366 ELSE
367*
368* 2-by-2 pivot interchange
369*
370* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
371*
372 i = i + 1
373 ip = -ipiv( i )
374 IF( i.LT.n ) THEN
375 IF( ip.NE.(i-1) ) THEN
376 CALL cswap( n-i, a( ip, i+1 ), lda,
377 $ a( i-1, i+1 ), lda )
378 END IF
379 END IF
380*
381* Convert IPIV
382* There is one interchange of rows i-1 and IPIV(i-1),
383* so this should be recorded in two consecutive entries
384* in IPIV format for *SYTRF
385*
386 ipiv( i ) = ipiv( i-1 )
387*
388 END IF
389 i = i + 1
390 END DO
391*
392* Revert VALUE
393* Assign superdiagonal entries of D from array E to
394* superdiagonal entries of A.
395*
396 i = n
397 DO WHILE ( i.GT.1 )
398 IF( ipiv( i ).LT.0 ) THEN
399 a( i-1, i ) = e( i )
400 i = i - 1
401 END IF
402 i = i - 1
403 END DO
404*
405* End A is UPPER
406*
407 END IF
408*
409 ELSE
410*
411* Begin A is LOWER
412*
413 IF ( convert ) THEN
414*
415* Convert A (A is lower)
416*
417*
418* Convert VALUE
419* Assign subdiagonal entries of D to array E and zero out
420* corresponding entries in input storage A
421*
422 i = 1
423 e( n ) = zero
424 DO WHILE ( i.LE.n )
425 IF( i.LT.n .AND. ipiv(i).LT.0 ) THEN
426 e( i ) = a( i+1, i )
427 e( i+1 ) = zero
428 a( i+1, i ) = zero
429 i = i + 1
430 ELSE
431 e( i ) = zero
432 END IF
433 i = i + 1
434 END DO
435*
436* Convert PERMUTATIONS and IPIV
437*
438* Apply permutations to submatrices of lower part of A
439* in factorization order where k increases from 1 to N
440*
441 i = 1
442 DO WHILE ( i.LE.n )
443 IF( ipiv( i ).GT.0 ) THEN
444*
445* 1-by-1 pivot interchange
446*
447* Swap rows i and IPIV(i) in A(i:N,1:i-1)
448*
449 ip = ipiv( i )
450 IF ( i.GT.1 ) THEN
451 IF( ip.NE.i ) THEN
452 CALL cswap( i-1, a( i, 1 ), lda,
453 $ a( ip, 1 ), lda )
454 END IF
455 END IF
456*
457 ELSE
458*
459* 2-by-2 pivot interchange
460*
461* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
462*
463 ip = -ipiv( i )
464 IF ( i.GT.1 ) THEN
465 IF( ip.NE.(i+1) ) THEN
466 CALL cswap( i-1, a( i+1, 1 ), lda,
467 $ a( ip, 1 ), lda )
468 END IF
469 END IF
470*
471* Convert IPIV
472* There is no interchnge of rows i and and IPIV(i),
473* so this should be reflected in IPIV format for
474* *SYTRF_RK ( or *SYTRF_BK)
475*
476 ipiv( i ) = i
477*
478 i = i + 1
479*
480 END IF
481 i = i + 1
482 END DO
483*
484 ELSE
485*
486* Revert A (A is lower)
487*
488*
489* Revert PERMUTATIONS and IPIV
490*
491* Apply permutations to submatrices of lower part of A
492* in reverse factorization order where i decreases from N to 1
493*
494 i = n
495 DO WHILE ( i.GE.1 )
496 IF( ipiv( i ).GT.0 ) THEN
497*
498* 1-by-1 pivot interchange
499*
500* Swap rows i and IPIV(i) in A(i:N,1:i-1)
501*
502 ip = ipiv( i )
503 IF ( i.GT.1 ) THEN
504 IF( ip.NE.i ) THEN
505 CALL cswap( i-1, a( ip, 1 ), lda,
506 $ a( i, 1 ), lda )
507 END IF
508 END IF
509*
510 ELSE
511*
512* 2-by-2 pivot interchange
513*
514* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
515*
516 i = i - 1
517 ip = -ipiv( i )
518 IF ( i.GT.1 ) THEN
519 IF( ip.NE.(i+1) ) THEN
520 CALL cswap( i-1, a( ip, 1 ), lda,
521 $ a( i+1, 1 ), lda )
522 END IF
523 END IF
524*
525* Convert IPIV
526* There is one interchange of rows i+1 and IPIV(i+1),
527* so this should be recorded in consecutive entries
528* in IPIV format for *SYTRF
529*
530 ipiv( i ) = ipiv( i+1 )
531*
532 END IF
533 i = i - 1
534 END DO
535*
536* Revert VALUE
537* Assign subdiagonal entries of D from array E to
538* subgiagonal entries of A.
539*
540 i = 1
541 DO WHILE ( i.LE.n-1 )
542 IF( ipiv( i ).LT.0 ) THEN
543 a( i + 1, i ) = e( i )
544 i = i + 1
545 END IF
546 i = i + 1
547 END DO
548*
549 END IF
550*
551* End A is LOWER
552*
553 END IF
554
555 RETURN
556*
557* End of CSYCONVF
558*

◆ csyconvf_rook()

subroutine csyconvf_rook ( character uplo,
character way,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
integer info )

CSYCONVF_ROOK

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

Purpose:
!> If parameter WAY = 'C':
!> CSYCONVF_ROOK converts the factorization output format used in
!> CSYTRF_ROOK provided on entry in parameter A into the factorization
!> output format used in CSYTRF_RK (or CSYTRF_BK) that is stored
!> on exit in parameters A and E. IPIV format for CSYTRF_ROOK and
!> CSYTRF_RK (or CSYTRF_BK) is the same and is not converted.
!>
!> If parameter WAY = 'R':
!> CSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!> converts the factorization output format used in CSYTRF_RK
!> (or CSYTRF_BK) provided on entry in parameters A and E into
!> the factorization output format used in CSYTRF_ROOK that is stored
!> on exit in parameter A. IPIV format for CSYTRF_ROOK and
!> CSYTRF_RK (or CSYTRF_BK) is the same and is not converted.
!>
!> CSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between
!> formats used in CHETRF_ROOK and CHETRF_RK (or CHETRF_BK).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are
!>          stored as an upper or lower triangular matrix A.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]WAY
!>          WAY is CHARACTER*1
!>          = 'C': Convert
!>          = 'R': Revert
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>
!>          1) If WAY ='C':
!>
!>          On entry, contains factorization details in format used in
!>          CSYTRF_ROOK:
!>            a) all elements of the symmetric block diagonal
!>               matrix D on the diagonal of A and on superdiagonal
!>               (or subdiagonal) of A, and
!>            b) If UPLO = 'U': multipliers used to obtain factor U
!>               in the superdiagonal part of A.
!>               If UPLO = 'L': multipliers used to obtain factor L
!>               in the superdiagonal part of A.
!>
!>          On exit, contains factorization details in format used in
!>          CSYTRF_RK or CSYTRF_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
!>                are stored on exit 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.
!>
!>          2) If WAY = 'R':
!>
!>          On entry, contains factorization details in format used in
!>          CSYTRF_RK or CSYTRF_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
!>                are stored on exit 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, contains factorization details in format used in
!>          CSYTRF_ROOK:
!>            a) all elements of the symmetric block diagonal
!>               matrix D on the diagonal of A and on superdiagonal
!>               (or subdiagonal) of A, and
!>            b) If UPLO = 'U': multipliers used to obtain factor U
!>               in the superdiagonal part of A.
!>               If UPLO = 'L': multipliers used to obtain factor L
!>               in the superdiagonal part of A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]E
!>          E is COMPLEX array, dimension (N)
!>
!>          1) If WAY ='C':
!>
!>          On entry, just a workspace.
!>
!>          On exit, 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) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          2) If WAY = 'R':
!>
!>          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 referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
!>          On exit, is not changed
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On entry, details of the interchanges and the block
!>          structure of D as determined:
!>          1) by CSYTRF_ROOK, if WAY ='C';
!>          2) by CSYTRF_RK (or CSYTRF_BK), if WAY ='R'.
!>          The IPIV format is the same for all these routines.
!>
!>          On exit, is not changed.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>  November 2017,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>

Definition at line 199 of file csyconvf_rook.f.

200*
201* -- LAPACK computational routine --
202* -- LAPACK is a software package provided by Univ. of Tennessee, --
203* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
204*
205* .. Scalar Arguments ..
206 CHARACTER UPLO, WAY
207 INTEGER INFO, LDA, N
208* ..
209* .. Array Arguments ..
210 INTEGER IPIV( * )
211 COMPLEX A( LDA, * ), E( * )
212* ..
213*
214* =====================================================================
215*
216* .. Parameters ..
217 COMPLEX ZERO
218 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
219* ..
220* .. External Functions ..
221 LOGICAL LSAME
222 EXTERNAL lsame
223*
224* .. External Subroutines ..
225 EXTERNAL cswap, xerbla
226* .. Local Scalars ..
227 LOGICAL UPPER, CONVERT
228 INTEGER I, IP, IP2
229* ..
230* .. Executable Statements ..
231*
232 info = 0
233 upper = lsame( uplo, 'U' )
234 convert = lsame( way, 'C' )
235 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
236 info = -1
237 ELSE IF( .NOT.convert .AND. .NOT.lsame( way, 'R' ) ) THEN
238 info = -2
239 ELSE IF( n.LT.0 ) THEN
240 info = -3
241 ELSE IF( lda.LT.max( 1, n ) ) THEN
242 info = -5
243
244 END IF
245 IF( info.NE.0 ) THEN
246 CALL xerbla( 'CSYCONVF_ROOK', -info )
247 RETURN
248 END IF
249*
250* Quick return if possible
251*
252 IF( n.EQ.0 )
253 $ RETURN
254*
255 IF( upper ) THEN
256*
257* Begin A is UPPER
258*
259 IF ( convert ) THEN
260*
261* Convert A (A is upper)
262*
263*
264* Convert VALUE
265*
266* Assign superdiagonal entries of D to array E and zero out
267* corresponding entries in input storage A
268*
269 i = n
270 e( 1 ) = zero
271 DO WHILE ( i.GT.1 )
272 IF( ipiv( i ).LT.0 ) THEN
273 e( i ) = a( i-1, i )
274 e( i-1 ) = zero
275 a( i-1, i ) = zero
276 i = i - 1
277 ELSE
278 e( i ) = zero
279 END IF
280 i = i - 1
281 END DO
282*
283* Convert PERMUTATIONS
284*
285* Apply permutations to submatrices of upper part of A
286* in factorization order where i decreases from N to 1
287*
288 i = n
289 DO WHILE ( i.GE.1 )
290 IF( ipiv( i ).GT.0 ) THEN
291*
292* 1-by-1 pivot interchange
293*
294* Swap rows i and IPIV(i) in A(1:i,N-i:N)
295*
296 ip = ipiv( i )
297 IF( i.LT.n ) THEN
298 IF( ip.NE.i ) THEN
299 CALL cswap( n-i, a( i, i+1 ), lda,
300 $ a( ip, i+1 ), lda )
301 END IF
302 END IF
303*
304 ELSE
305*
306* 2-by-2 pivot interchange
307*
308* Swap rows i and IPIV(i) and i-1 and IPIV(i-1)
309* in A(1:i,N-i:N)
310*
311 ip = -ipiv( i )
312 ip2 = -ipiv( i-1 )
313 IF( i.LT.n ) THEN
314 IF( ip.NE.i ) THEN
315 CALL cswap( n-i, a( i, i+1 ), lda,
316 $ a( ip, i+1 ), lda )
317 END IF
318 IF( ip2.NE.(i-1) ) THEN
319 CALL cswap( n-i, a( i-1, i+1 ), lda,
320 $ a( ip2, i+1 ), lda )
321 END IF
322 END IF
323 i = i - 1
324*
325 END IF
326 i = i - 1
327 END DO
328*
329 ELSE
330*
331* Revert A (A is upper)
332*
333*
334* Revert PERMUTATIONS
335*
336* Apply permutations to submatrices of upper part of A
337* in reverse factorization order where i increases from 1 to N
338*
339 i = 1
340 DO WHILE ( i.LE.n )
341 IF( ipiv( i ).GT.0 ) THEN
342*
343* 1-by-1 pivot interchange
344*
345* Swap rows i and IPIV(i) in A(1:i,N-i:N)
346*
347 ip = ipiv( i )
348 IF( i.LT.n ) THEN
349 IF( ip.NE.i ) THEN
350 CALL cswap( n-i, a( ip, i+1 ), lda,
351 $ a( i, i+1 ), lda )
352 END IF
353 END IF
354*
355 ELSE
356*
357* 2-by-2 pivot interchange
358*
359* Swap rows i-1 and IPIV(i-1) and i and IPIV(i)
360* in A(1:i,N-i:N)
361*
362 i = i + 1
363 ip = -ipiv( i )
364 ip2 = -ipiv( i-1 )
365 IF( i.LT.n ) THEN
366 IF( ip2.NE.(i-1) ) THEN
367 CALL cswap( n-i, a( ip2, i+1 ), lda,
368 $ a( i-1, i+1 ), lda )
369 END IF
370 IF( ip.NE.i ) THEN
371 CALL cswap( n-i, a( ip, i+1 ), lda,
372 $ a( i, i+1 ), lda )
373 END IF
374 END IF
375*
376 END IF
377 i = i + 1
378 END DO
379*
380* Revert VALUE
381* Assign superdiagonal entries of D from array E to
382* superdiagonal entries of A.
383*
384 i = n
385 DO WHILE ( i.GT.1 )
386 IF( ipiv( i ).LT.0 ) THEN
387 a( i-1, i ) = e( i )
388 i = i - 1
389 END IF
390 i = i - 1
391 END DO
392*
393* End A is UPPER
394*
395 END IF
396*
397 ELSE
398*
399* Begin A is LOWER
400*
401 IF ( convert ) THEN
402*
403* Convert A (A is lower)
404*
405*
406* Convert VALUE
407* Assign subdiagonal entries of D to array E and zero out
408* corresponding entries in input storage A
409*
410 i = 1
411 e( n ) = zero
412 DO WHILE ( i.LE.n )
413 IF( i.LT.n .AND. ipiv(i).LT.0 ) THEN
414 e( i ) = a( i+1, i )
415 e( i+1 ) = zero
416 a( i+1, i ) = zero
417 i = i + 1
418 ELSE
419 e( i ) = zero
420 END IF
421 i = i + 1
422 END DO
423*
424* Convert PERMUTATIONS
425*
426* Apply permutations to submatrices of lower part of A
427* in factorization order where i increases from 1 to N
428*
429 i = 1
430 DO WHILE ( i.LE.n )
431 IF( ipiv( i ).GT.0 ) THEN
432*
433* 1-by-1 pivot interchange
434*
435* Swap rows i and IPIV(i) in A(i:N,1:i-1)
436*
437 ip = ipiv( i )
438 IF ( i.GT.1 ) THEN
439 IF( ip.NE.i ) THEN
440 CALL cswap( i-1, a( i, 1 ), lda,
441 $ a( ip, 1 ), lda )
442 END IF
443 END IF
444*
445 ELSE
446*
447* 2-by-2 pivot interchange
448*
449* Swap rows i and IPIV(i) and i+1 and IPIV(i+1)
450* in A(i:N,1:i-1)
451*
452 ip = -ipiv( i )
453 ip2 = -ipiv( i+1 )
454 IF ( i.GT.1 ) THEN
455 IF( ip.NE.i ) THEN
456 CALL cswap( i-1, a( i, 1 ), lda,
457 $ a( ip, 1 ), lda )
458 END IF
459 IF( ip2.NE.(i+1) ) THEN
460 CALL cswap( i-1, a( i+1, 1 ), lda,
461 $ a( ip2, 1 ), lda )
462 END IF
463 END IF
464 i = i + 1
465*
466 END IF
467 i = i + 1
468 END DO
469*
470 ELSE
471*
472* Revert A (A is lower)
473*
474*
475* Revert PERMUTATIONS
476*
477* Apply permutations to submatrices of lower part of A
478* in reverse factorization order where i decreases from N to 1
479*
480 i = n
481 DO WHILE ( i.GE.1 )
482 IF( ipiv( i ).GT.0 ) THEN
483*
484* 1-by-1 pivot interchange
485*
486* Swap rows i and IPIV(i) in A(i:N,1:i-1)
487*
488 ip = ipiv( i )
489 IF ( i.GT.1 ) THEN
490 IF( ip.NE.i ) THEN
491 CALL cswap( i-1, a( ip, 1 ), lda,
492 $ a( i, 1 ), lda )
493 END IF
494 END IF
495*
496 ELSE
497*
498* 2-by-2 pivot interchange
499*
500* Swap rows i+1 and IPIV(i+1) and i and IPIV(i)
501* in A(i:N,1:i-1)
502*
503 i = i - 1
504 ip = -ipiv( i )
505 ip2 = -ipiv( i+1 )
506 IF ( i.GT.1 ) THEN
507 IF( ip2.NE.(i+1) ) THEN
508 CALL cswap( i-1, a( ip2, 1 ), lda,
509 $ a( i+1, 1 ), lda )
510 END IF
511 IF( ip.NE.i ) THEN
512 CALL cswap( i-1, a( ip, 1 ), lda,
513 $ a( i, 1 ), lda )
514 END IF
515 END IF
516*
517 END IF
518 i = i - 1
519 END DO
520*
521* Revert VALUE
522* Assign subdiagonal entries of D from array E to
523* subgiagonal entries of A.
524*
525 i = 1
526 DO WHILE ( i.LE.n-1 )
527 IF( ipiv( i ).LT.0 ) THEN
528 a( i + 1, i ) = e( i )
529 i = i + 1
530 END IF
531 i = i + 1
532 END DO
533*
534 END IF
535*
536* End A is LOWER
537*
538 END IF
539
540 RETURN
541*
542* End of CSYCONVF_ROOK
543*

◆ csyequb()

subroutine csyequb ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s,
real scond,
real amax,
complex, dimension( * ) work,
integer info )

CSYEQUB

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

Purpose:
!>
!> CSYEQUB computes row and column scalings intended to equilibrate a
!> symmetric matrix A (with respect to the Euclidean norm) and reduce
!> its condition number. The scale factors S are computed by the BIN
!> algorithm (see references) so that the scaled matrix B with elements
!> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
!> the smallest possible condition number over all possible diagonal
!> scalings.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The N-by-N symmetric matrix whose scaling factors are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[out]S
!>          S is REAL array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is REAL
!>          If INFO = 0, S contains the ratio of the smallest S(i) to
!>          the largest S(i). If SCOND >= 0.1 and AMAX is neither too
!>          large nor too small, it is not worth scaling by S.
!>
[out]AMAX
!>          AMAX is REAL
!>          Largest absolute value of any matrix element. If AMAX is
!>          very close to overflow or very close to underflow, the
!>          matrix should be scaled.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*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, the i-th diagonal element is nonpositive.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
References:
Livne, O.E. and Golub, G.H., "Scaling by Binormalization",
Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.
DOI 10.1023/B:NUMA.0000016606.32820.69
Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679

Definition at line 131 of file csyequb.f.

132*
133* -- LAPACK computational routine --
134* -- LAPACK is a software package provided by Univ. of Tennessee, --
135* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136*
137* .. Scalar Arguments ..
138 INTEGER INFO, LDA, N
139 REAL AMAX, SCOND
140 CHARACTER UPLO
141* ..
142* .. Array Arguments ..
143 COMPLEX A( LDA, * ), WORK( * )
144 REAL S( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 REAL ONE, ZERO
151 parameter( one = 1.0e0, zero = 0.0e0 )
152 INTEGER MAX_ITER
153 parameter( max_iter = 100 )
154* ..
155* .. Local Scalars ..
156 INTEGER I, J, ITER
157 REAL AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE,
158 $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ
159 LOGICAL UP
160 COMPLEX ZDUM
161* ..
162* .. External Functions ..
163 REAL SLAMCH
164 LOGICAL LSAME
165 EXTERNAL lsame, slamch
166* ..
167* .. External Subroutines ..
168 EXTERNAL classq, xerbla
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, aimag, int, log, max, min, real, sqrt
172* ..
173* .. Statement Functions ..
174 REAL CABS1
175* ..
176* .. Statement Function Definitions ..
177 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
178* ..
179* .. Executable Statements ..
180*
181* Test the input parameters.
182*
183 info = 0
184 IF ( .NOT. ( lsame( uplo, 'U' ) .OR. lsame( uplo, 'L' ) ) ) THEN
185 info = -1
186 ELSE IF ( n .LT. 0 ) THEN
187 info = -2
188 ELSE IF ( lda .LT. max( 1, n ) ) THEN
189 info = -4
190 END IF
191 IF ( info .NE. 0 ) THEN
192 CALL xerbla( 'CSYEQUB', -info )
193 RETURN
194 END IF
195
196 up = lsame( uplo, 'U' )
197 amax = zero
198*
199* Quick return if possible.
200*
201 IF ( n .EQ. 0 ) THEN
202 scond = one
203 RETURN
204 END IF
205
206 DO i = 1, n
207 s( i ) = zero
208 END DO
209
210 amax = zero
211 IF ( up ) THEN
212 DO j = 1, n
213 DO i = 1, j-1
214 s( i ) = max( s( i ), cabs1( a( i, j ) ) )
215 s( j ) = max( s( j ), cabs1( a( i, j ) ) )
216 amax = max( amax, cabs1( a( i, j ) ) )
217 END DO
218 s( j ) = max( s( j ), cabs1( a( j, j ) ) )
219 amax = max( amax, cabs1( a( j, j ) ) )
220 END DO
221 ELSE
222 DO j = 1, n
223 s( j ) = max( s( j ), cabs1( a( j, j ) ) )
224 amax = max( amax, cabs1( a( j, j ) ) )
225 DO i = j+1, n
226 s( i ) = max( s( i ), cabs1( a( i, j ) ) )
227 s( j ) = max( s( j ), cabs1( a( i, j ) ) )
228 amax = max( amax, cabs1( a( i, j ) ) )
229 END DO
230 END DO
231 END IF
232 DO j = 1, n
233 s( j ) = 1.0 / s( j )
234 END DO
235
236 tol = one / sqrt( 2.0e0 * n )
237
238 DO iter = 1, max_iter
239 scale = 0.0e0
240 sumsq = 0.0e0
241* beta = |A|s
242 DO i = 1, n
243 work( i ) = zero
244 END DO
245 IF ( up ) THEN
246 DO j = 1, n
247 DO i = 1, j-1
248 work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
249 work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
250 END DO
251 work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
252 END DO
253 ELSE
254 DO j = 1, n
255 work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
256 DO i = j+1, n
257 work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
258 work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
259 END DO
260 END DO
261 END IF
262
263* avg = s^T beta / n
264 avg = 0.0e0
265 DO i = 1, n
266 avg = avg + real( s( i )*work( i ) )
267 END DO
268 avg = avg / n
269
270 std = 0.0e0
271 DO i = n+1, 2*n
272 work( i ) = s( i-n ) * work( i-n ) - avg
273 END DO
274 CALL classq( n, work( n+1 ), 1, scale, sumsq )
275 std = scale * sqrt( sumsq / n )
276
277 IF ( std .LT. tol * avg ) GOTO 999
278
279 DO i = 1, n
280 t = cabs1( a( i, i ) )
281 si = s( i )
282 c2 = ( n-1 ) * t
283 c1 = real( n-2 ) * ( real( work( i ) ) - t*si )
284 c0 = -(t*si)*si + 2 * real( work( i ) ) * si - n*avg
285 d = c1*c1 - 4*c0*c2
286
287 IF ( d .LE. 0 ) THEN
288 info = -1
289 RETURN
290 END IF
291 si = -2*c0 / ( c1 + sqrt( d ) )
292
293 d = si - s( i )
294 u = zero
295 IF ( up ) THEN
296 DO j = 1, i
297 t = cabs1( a( j, i ) )
298 u = u + s( j )*t
299 work( j ) = work( j ) + d*t
300 END DO
301 DO j = i+1,n
302 t = cabs1( a( i, j ) )
303 u = u + s( j )*t
304 work( j ) = work( j ) + d*t
305 END DO
306 ELSE
307 DO j = 1, i
308 t = cabs1( a( i, j ) )
309 u = u + s( j )*t
310 work( j ) = work( j ) + d*t
311 END DO
312 DO j = i+1,n
313 t = cabs1( a( j, i ) )
314 u = u + s( j )*t
315 work( j ) = work( j ) + d*t
316 END DO
317 END IF
318
319 avg = avg + ( u + real( work( i ) ) ) * d / n
320 s( i ) = si
321 END DO
322 END DO
323
324 999 CONTINUE
325
326 smlnum = slamch( 'SAFEMIN' )
327 bignum = one / smlnum
328 smin = bignum
329 smax = zero
330 t = one / sqrt( avg )
331 base = slamch( 'B' )
332 u = one / log( base )
333 DO i = 1, n
334 s( i ) = base ** int( u * log( s( i ) * t ) )
335 smin = min( smin, s( i ) )
336 smax = max( smax, s( i ) )
337 END DO
338 scond = max( smin, smlnum ) / min( smax, bignum )
339*
classq
subroutine classq(n, x, incx, scl, sumsq)
CLASSQ updates a sum of squares represented in scaled form.
Definition classq.f90:137

◆ csyrfs()

subroutine csyrfs ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
real, dimension( * ) ferr,
real, dimension( * ) berr,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CSYRFS

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

Purpose:
!>
!> CSYRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is symmetric indefinite, and
!> provides error bounds and backward error estimates for the solution.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!>          upper triangular part of A contains the upper triangular part
!>          of the matrix A, and the strictly lower triangular part of A
!>          is not referenced.  If UPLO = 'L', the leading N-by-N lower
!>          triangular part of A contains the lower triangular part of
!>          the matrix A, and the strictly upper triangular part of A is
!>          not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDAF,N)
!>          The factored form of the matrix A.  AF contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor U or L from the factorization A = U*D*U**T or
!>          A = L*D*L**T as computed by CSYTRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>          The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by CSYTRF.
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by CSYTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is REAL array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is REAL array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Internal Parameters:
!>  ITMAX is the maximum number of steps of iterative refinement.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 190 of file csyrfs.f.

192*
193* -- LAPACK computational routine --
194* -- LAPACK is a software package provided by Univ. of Tennessee, --
195* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
196*
197* .. Scalar Arguments ..
198 CHARACTER UPLO
199 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
200* ..
201* .. Array Arguments ..
202 INTEGER IPIV( * )
203 REAL BERR( * ), FERR( * ), RWORK( * )
204 COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
205 $ WORK( * ), X( LDX, * )
206* ..
207*
208* =====================================================================
209*
210* .. Parameters ..
211 INTEGER ITMAX
212 parameter( itmax = 5 )
213 REAL ZERO
214 parameter( zero = 0.0e+0 )
215 COMPLEX ONE
216 parameter( one = ( 1.0e+0, 0.0e+0 ) )
217 REAL TWO
218 parameter( two = 2.0e+0 )
219 REAL THREE
220 parameter( three = 3.0e+0 )
221* ..
222* .. Local Scalars ..
223 LOGICAL UPPER
224 INTEGER COUNT, I, J, K, KASE, NZ
225 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
226 COMPLEX ZDUM
227* ..
228* .. Local Arrays ..
229 INTEGER ISAVE( 3 )
230* ..
231* .. External Subroutines ..
232 EXTERNAL caxpy, ccopy, clacn2, csymv, csytrs, xerbla
233* ..
234* .. Intrinsic Functions ..
235 INTRINSIC abs, aimag, max, real
236* ..
237* .. External Functions ..
238 LOGICAL LSAME
239 REAL SLAMCH
240 EXTERNAL lsame, slamch
241* ..
242* .. Statement Functions ..
243 REAL CABS1
244* ..
245* .. Statement Function definitions ..
246 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
247* ..
248* .. Executable Statements ..
249*
250* Test the input parameters.
251*
252 info = 0
253 upper = lsame( uplo, 'U' )
254 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
255 info = -1
256 ELSE IF( n.LT.0 ) THEN
257 info = -2
258 ELSE IF( nrhs.LT.0 ) THEN
259 info = -3
260 ELSE IF( lda.LT.max( 1, n ) ) THEN
261 info = -5
262 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
263 info = -7
264 ELSE IF( ldb.LT.max( 1, n ) ) THEN
265 info = -10
266 ELSE IF( ldx.LT.max( 1, n ) ) THEN
267 info = -12
268 END IF
269 IF( info.NE.0 ) THEN
270 CALL xerbla( 'CSYRFS', -info )
271 RETURN
272 END IF
273*
274* Quick return if possible
275*
276 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
277 DO 10 j = 1, nrhs
278 ferr( j ) = zero
279 berr( j ) = zero
280 10 CONTINUE
281 RETURN
282 END IF
283*
284* NZ = maximum number of nonzero elements in each row of A, plus 1
285*
286 nz = n + 1
287 eps = slamch( 'Epsilon' )
288 safmin = slamch( 'Safe minimum' )
289 safe1 = nz*safmin
290 safe2 = safe1 / eps
291*
292* Do for each right hand side
293*
294 DO 140 j = 1, nrhs
295*
296 count = 1
297 lstres = three
298 20 CONTINUE
299*
300* Loop until stopping criterion is satisfied.
301*
302* Compute residual R = B - A * X
303*
304 CALL ccopy( n, b( 1, j ), 1, work, 1 )
305 CALL csymv( uplo, n, -one, a, lda, x( 1, j ), 1, one, work, 1 )
306*
307* Compute componentwise relative backward error from formula
308*
309* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
310*
311* where abs(Z) is the componentwise absolute value of the matrix
312* or vector Z. If the i-th component of the denominator is less
313* than SAFE2, then SAFE1 is added to the i-th components of the
314* numerator and denominator before dividing.
315*
316 DO 30 i = 1, n
317 rwork( i ) = cabs1( b( i, j ) )
318 30 CONTINUE
319*
320* Compute abs(A)*abs(X) + abs(B).
321*
322 IF( upper ) THEN
323 DO 50 k = 1, n
324 s = zero
325 xk = cabs1( x( k, j ) )
326 DO 40 i = 1, k - 1
327 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
328 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
329 40 CONTINUE
330 rwork( k ) = rwork( k ) + cabs1( a( k, k ) )*xk + s
331 50 CONTINUE
332 ELSE
333 DO 70 k = 1, n
334 s = zero
335 xk = cabs1( x( k, j ) )
336 rwork( k ) = rwork( k ) + cabs1( a( k, k ) )*xk
337 DO 60 i = k + 1, n
338 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
339 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
340 60 CONTINUE
341 rwork( k ) = rwork( k ) + s
342 70 CONTINUE
343 END IF
344 s = zero
345 DO 80 i = 1, n
346 IF( rwork( i ).GT.safe2 ) THEN
347 s = max( s, cabs1( work( i ) ) / rwork( i ) )
348 ELSE
349 s = max( s, ( cabs1( work( i ) )+safe1 ) /
350 $ ( rwork( i )+safe1 ) )
351 END IF
352 80 CONTINUE
353 berr( j ) = s
354*
355* Test stopping criterion. Continue iterating if
356* 1) The residual BERR(J) is larger than machine epsilon, and
357* 2) BERR(J) decreased by at least a factor of 2 during the
358* last iteration, and
359* 3) At most ITMAX iterations tried.
360*
361 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
362 $ count.LE.itmax ) THEN
363*
364* Update solution and try again.
365*
366 CALL csytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
367 CALL caxpy( n, one, work, 1, x( 1, j ), 1 )
368 lstres = berr( j )
369 count = count + 1
370 GO TO 20
371 END IF
372*
373* Bound error from formula
374*
375* norm(X - XTRUE) / norm(X) .le. FERR =
376* norm( abs(inv(A))*
377* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
378*
379* where
380* norm(Z) is the magnitude of the largest component of Z
381* inv(A) is the inverse of A
382* abs(Z) is the componentwise absolute value of the matrix or
383* vector Z
384* NZ is the maximum number of nonzeros in any row of A, plus 1
385* EPS is machine epsilon
386*
387* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
388* is incremented by SAFE1 if the i-th component of
389* abs(A)*abs(X) + abs(B) is less than SAFE2.
390*
391* Use CLACN2 to estimate the infinity-norm of the matrix
392* inv(A) * diag(W),
393* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
394*
395 DO 90 i = 1, n
396 IF( rwork( i ).GT.safe2 ) THEN
397 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
398 ELSE
399 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
400 $ safe1
401 END IF
402 90 CONTINUE
403*
404 kase = 0
405 100 CONTINUE
406 CALL clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
407 IF( kase.NE.0 ) THEN
408 IF( kase.EQ.1 ) THEN
409*
410* Multiply by diag(W)*inv(A**T).
411*
412 CALL csytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
413 DO 110 i = 1, n
414 work( i ) = rwork( i )*work( i )
415 110 CONTINUE
416 ELSE IF( kase.EQ.2 ) THEN
417*
418* Multiply by inv(A)*diag(W).
419*
420 DO 120 i = 1, n
421 work( i ) = rwork( i )*work( i )
422 120 CONTINUE
423 CALL csytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
424 END IF
425 GO TO 100
426 END IF
427*
428* Normalize error.
429*
430 lstres = zero
431 DO 130 i = 1, n
432 lstres = max( lstres, cabs1( x( i, j ) ) )
433 130 CONTINUE
434 IF( lstres.NE.zero )
435 $ ferr( j ) = ferr( j ) / lstres
436*
437 140 CONTINUE
438*
439 RETURN
440*
441* End of CSYRFS
442*

◆ csyrfsx()

subroutine csyrfsx ( character uplo,
character equed,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
real, dimension( * ) s,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
real rcond,
real, dimension( * ) berr,
integer n_err_bnds,
real, dimension( nrhs, * ) err_bnds_norm,
real, dimension( nrhs, * ) err_bnds_comp,
integer nparams,
real, dimension( * ) params,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CSYRFSX

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

Purpose:
!>
!>    CSYRFSX improves the computed solution to a system of linear
!>    equations when the coefficient matrix is symmetric indefinite, and
!>    provides error bounds and backward error estimates for the
!>    solution.  In addition to normwise error bound, the code provides
!>    maximum componentwise error bound if possible.  See comments for
!>    ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
!>
!>    The original system of linear equations may have been equilibrated
!>    before calling this routine, as described by arguments EQUED and S
!>    below. In this case, the solution and error bounds returned are
!>    for the original unequilibrated system.
!> 
!>     Some optional parameters are bundled in the PARAMS array.  These
!>     settings determine how refinement is performed, but often the
!>     defaults are acceptable.  If the defaults are acceptable, users
!>     can pass NPARAMS = 0 which prevents the source code from accessing
!>     the PARAMS argument.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]EQUED
!>          EQUED is CHARACTER*1
!>     Specifies the form of equilibration that was done to A
!>     before calling this routine. This is needed to compute
!>     the solution and error bounds correctly.
!>       = 'N':  No equilibration
!>       = 'Y':  Both row and column equilibration, i.e., A has been
!>               replaced by diag(S) * A * diag(S).
!>               The right hand side B has been changed accordingly.
!>
[in]N
!>          N is INTEGER
!>     The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>     The number of right hand sides, i.e., the number of columns
!>     of the matrices B and X.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!>     upper triangular part of A contains the upper triangular
!>     part of the matrix A, and the strictly lower triangular
!>     part of A is not referenced.  If UPLO = 'L', the leading
!>     N-by-N lower triangular part of A contains the lower
!>     triangular part of the matrix A, and the strictly upper
!>     triangular part of A is not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDAF,N)
!>     The factored form of the matrix A.  AF contains the block
!>     diagonal matrix D and the multipliers used to obtain the
!>     factor U or L from the factorization A = U*D*U**T or A =
!>     L*D*L**T as computed by CSYTRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     Details of the interchanges and the block structure of D
!>     as determined by CSYTRF.
!>
[in,out]S
!>          S is REAL array, dimension (N)
!>     The scale factors for A.  If EQUED = 'Y', A is multiplied on
!>     the left and right by diag(S).  S is an input argument if FACT =
!>     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED
!>     = 'Y', each element of S must be positive.  If S is output, each
!>     element of S is a power of the radix. If S is input, each element
!>     of S should be a power of the radix to ensure a reliable solution
!>     and error estimates. Scaling by powers of the radix does not cause
!>     rounding errors unless the result underflows or overflows.
!>     Rounding errors during scaling lead to refining with a matrix that
!>     is not equivalent to the input matrix, producing error estimates
!>     that may not be reliable.
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>     The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>     The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX array, dimension (LDX,NRHS)
!>     On entry, the solution matrix X, as computed by CGETRS.
!>     On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>     The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]RCOND
!>          RCOND is REAL
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[out]BERR
!>          BERR is REAL array, dimension (NRHS)
!>     Componentwise relative backward error.  This is the
!>     componentwise relative backward error of each solution vector X(j)
!>     (i.e., the smallest relative change in any element of A or B that
!>     makes X(j) an exact solution).
!>
[in]N_ERR_BNDS
!>          N_ERR_BNDS is INTEGER
!>     Number of error bounds to return for each right hand side
!>     and each type (normwise or componentwise).  See ERR_BNDS_NORM and
!>     ERR_BNDS_COMP below.
!>
[out]ERR_BNDS_NORM
!>          ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]NPARAMS
!>          NPARAMS is INTEGER
!>     Specifies the number of parameters set in PARAMS.  If <= 0, the
!>     PARAMS array is never referenced and default values are used.
!>
[in,out]PARAMS
!>          PARAMS is REAL array, dimension NPARAMS
!>     Specifies algorithm parameters.  If an entry is < 0.0, then
!>     that entry will be filled with default value used for that
!>     parameter.  Only positions up to NPARAMS are accessed; defaults
!>     are used for higher-numbered parameters.
!>
!>       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
!>            refinement or not.
!>         Default: 1.0
!>            = 0.0:  No refinement is performed, and no error bounds are
!>                    computed.
!>            = 1.0:  Use the double-precision refinement algorithm,
!>                    possibly with doubled-single computations if the
!>                    compilation environment does not support DOUBLE
!>                    PRECISION.
!>              (other values are reserved for future use)
!>
!>       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
!>            computations allowed for refinement.
!>         Default: 10
!>         Aggressive: Set to 100 to permit convergence using approximate
!>                     factorizations or factorizations other than LU. If
!>                     the factorization uses a technique other than
!>                     Gaussian elimination, the guarantees in
!>                     err_bnds_norm and err_bnds_comp may no longer be
!>                     trustworthy.
!>
!>       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
!>            will attempt to find a solution with small componentwise
!>            relative error in the double-precision algorithm.  Positive
!>            is true, 0.0 is false.
!>         Default: 1.0 (attempt componentwise convergence)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit. The solution to every right-hand side is
!>         guaranteed.
!>       < 0:  If INFO = -i, the i-th argument had an illegal value
!>       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization
!>         has been completed, but the factor U is exactly singular, so
!>         the solution and error bounds could not be computed. RCOND = 0
!>         is returned.
!>       = N+J: The solution corresponding to the Jth right-hand side is
!>         not guaranteed. The solutions corresponding to other right-
!>         hand sides K with K > J may not be guaranteed as well, but
!>         only the first such right-hand side is reported. If a small
!>         componentwise error is not requested (PARAMS(3) = 0.0) then
!>         the Jth right-hand side is the first with a normwise error
!>         bound that is not guaranteed (the smallest J such
!>         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
!>         the Jth right-hand side is the first with either a normwise or
!>         componentwise error bound that is not guaranteed (the smallest
!>         J such that either ERR_BNDS_NORM(J,1) = 0.0 or
!>         ERR_BNDS_COMP(J,1) = 0.0). See the definition of
!>         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
!>         about all of the right-hand sides check ERR_BNDS_NORM or
!>         ERR_BNDS_COMP.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 398 of file csyrfsx.f.

402*
403* -- LAPACK computational routine --
404* -- LAPACK is a software package provided by Univ. of Tennessee, --
405* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
406*
407* .. Scalar Arguments ..
408 CHARACTER UPLO, EQUED
409 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
410 $ N_ERR_BNDS
411 REAL RCOND
412* ..
413* .. Array Arguments ..
414 INTEGER IPIV( * )
415 COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
416 $ X( LDX, * ), WORK( * )
417 REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ),
418 $ ERR_BNDS_NORM( NRHS, * ),
419 $ ERR_BNDS_COMP( NRHS, * )
420* ..
421*
422* ==================================================================
423*
424* .. Parameters ..
425 REAL ZERO, ONE
426 parameter( zero = 0.0e+0, one = 1.0e+0 )
427 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
428 $ COMPONENTWISE_DEFAULT
429 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
430 parameter( itref_default = 1.0 )
431 parameter( ithresh_default = 10.0 )
432 parameter( componentwise_default = 1.0 )
433 parameter( rthresh_default = 0.5 )
434 parameter( dzthresh_default = 0.25 )
435 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
436 $ LA_LINRX_CWISE_I
437 parameter( la_linrx_itref_i = 1,
438 $ la_linrx_ithresh_i = 2 )
439 parameter( la_linrx_cwise_i = 3 )
440 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
441 $ LA_LINRX_RCOND_I
442 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
443 parameter( la_linrx_rcond_i = 3 )
444* ..
445* .. Local Scalars ..
446 CHARACTER(1) NORM
447 LOGICAL RCEQU
448 INTEGER J, PREC_TYPE, REF_TYPE
449 INTEGER N_NORMS
450 REAL ANORM, RCOND_TMP
451 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
452 LOGICAL IGNORE_CWISE
453 INTEGER ITHRESH
454 REAL RTHRESH, UNSTABLE_THRESH
455* ..
456* .. External Subroutines ..
457 EXTERNAL xerbla, csycon, cla_syrfsx_extended
458* ..
459* .. Intrinsic Functions ..
460 INTRINSIC max, sqrt, transfer
461* ..
462* .. External Functions ..
463 EXTERNAL lsame, ilaprec
464 EXTERNAL slamch, clansy, cla_syrcond_x, cla_syrcond_c
465 REAL SLAMCH, CLANSY, CLA_SYRCOND_X, CLA_SYRCOND_C
466 LOGICAL LSAME
467 INTEGER ILAPREC
468* ..
469* .. Executable Statements ..
470*
471* Check the input parameters.
472*
473 info = 0
474 ref_type = int( itref_default )
475 IF ( nparams .GE. la_linrx_itref_i ) THEN
476 IF ( params( la_linrx_itref_i ) .LT. 0.0 ) THEN
477 params( la_linrx_itref_i ) = itref_default
478 ELSE
479 ref_type = params( la_linrx_itref_i )
480 END IF
481 END IF
482*
483* Set default parameters.
484*
485 illrcond_thresh = real( n ) * slamch( 'Epsilon' )
486 ithresh = int( ithresh_default )
487 rthresh = rthresh_default
488 unstable_thresh = dzthresh_default
489 ignore_cwise = componentwise_default .EQ. 0.0
490*
491 IF ( nparams.GE.la_linrx_ithresh_i ) THEN
492 IF ( params( la_linrx_ithresh_i ).LT.0.0 ) THEN
493 params( la_linrx_ithresh_i ) = ithresh
494 ELSE
495 ithresh = int( params( la_linrx_ithresh_i ) )
496 END IF
497 END IF
498 IF ( nparams.GE.la_linrx_cwise_i ) THEN
499 IF ( params( la_linrx_cwise_i ).LT.0.0 ) THEN
500 IF ( ignore_cwise ) THEN
501 params( la_linrx_cwise_i ) = 0.0
502 ELSE
503 params( la_linrx_cwise_i ) = 1.0
504 END IF
505 ELSE
506 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
507 END IF
508 END IF
509 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 ) THEN
510 n_norms = 0
511 ELSE IF ( ignore_cwise ) THEN
512 n_norms = 1
513 ELSE
514 n_norms = 2
515 END IF
516*
517 rcequ = lsame( equed, 'Y' )
518*
519* Test input parameters.
520*
521 IF ( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
522 info = -1
523 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed, 'N' ) ) THEN
524 info = -2
525 ELSE IF( n.LT.0 ) THEN
526 info = -3
527 ELSE IF( nrhs.LT.0 ) THEN
528 info = -4
529 ELSE IF( lda.LT.max( 1, n ) ) THEN
530 info = -6
531 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
532 info = -8
533 ELSE IF( ldb.LT.max( 1, n ) ) THEN
534 info = -12
535 ELSE IF( ldx.LT.max( 1, n ) ) THEN
536 info = -14
537 END IF
538 IF( info.NE.0 ) THEN
539 CALL xerbla( 'CSYRFSX', -info )
540 RETURN
541 END IF
542*
543* Quick return if possible.
544*
545 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
546 rcond = 1.0
547 DO j = 1, nrhs
548 berr( j ) = 0.0
549 IF ( n_err_bnds .GE. 1 ) THEN
550 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
551 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
552 END IF
553 IF ( n_err_bnds .GE. 2 ) THEN
554 err_bnds_norm( j, la_linrx_err_i ) = 0.0
555 err_bnds_comp( j, la_linrx_err_i ) = 0.0
556 END IF
557 IF ( n_err_bnds .GE. 3 ) THEN
558 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
559 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
560 END IF
561 END DO
562 RETURN
563 END IF
564*
565* Default to failure.
566*
567 rcond = 0.0
568 DO j = 1, nrhs
569 berr( j ) = 1.0
570 IF ( n_err_bnds .GE. 1 ) THEN
571 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
572 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
573 END IF
574 IF ( n_err_bnds .GE. 2 ) THEN
575 err_bnds_norm( j, la_linrx_err_i ) = 1.0
576 err_bnds_comp( j, la_linrx_err_i ) = 1.0
577 END IF
578 IF ( n_err_bnds .GE. 3 ) THEN
579 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
580 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
581 END IF
582 END DO
583*
584* Compute the norm of A and the reciprocal of the condition
585* number of A.
586*
587 norm = 'I'
588 anorm = clansy( norm, uplo, n, a, lda, rwork )
589 CALL csycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work,
590 $ info )
591*
592* Perform refinement on each right-hand side
593*
594 IF ( ref_type .NE. 0 ) THEN
595
596 prec_type = ilaprec( 'D' )
597
598 CALL cla_syrfsx_extended( prec_type, uplo, n,
599 $ nrhs, a, lda, af, ldaf, ipiv, rcequ, s, b,
600 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
601 $ work, rwork, work(n+1),
602 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n), rcond,
603 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
604 $ info )
605 END IF
606
607 err_lbnd = max( 10.0, sqrt( real( n ) ) ) * slamch( 'Epsilon' )
608 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 1) THEN
609*
610* Compute scaled normwise condition number cond(A*C).
611*
612 IF ( rcequ ) THEN
613 rcond_tmp = cla_syrcond_c( uplo, n, a, lda, af, ldaf, ipiv,
614 $ s, .true., info, work, rwork )
615 ELSE
616 rcond_tmp = cla_syrcond_c( uplo, n, a, lda, af, ldaf, ipiv,
617 $ s, .false., info, work, rwork )
618 END IF
619 DO j = 1, nrhs
620*
621* Cap the error at 1.0.
622*
623 IF ( n_err_bnds .GE. la_linrx_err_i
624 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
625 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
626*
627* Threshold the error (see LAWN).
628*
629 IF ( rcond_tmp .LT. illrcond_thresh ) THEN
630 err_bnds_norm( j, la_linrx_err_i ) = 1.0
631 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
632 IF ( info .LE. n ) info = n + j
633 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
634 $ THEN
635 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
636 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
637 END IF
638*
639* Save the condition number.
640*
641 IF ( n_err_bnds .GE. la_linrx_rcond_i ) THEN
642 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
643 END IF
644 END DO
645 END IF
646
647 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 ) THEN
648*
649* Compute componentwise condition number cond(A*diag(Y(:,J))) for
650* each right-hand side using the current solution as an estimate of
651* the true solution. If the componentwise error estimate is too
652* large, then the solution is a lousy estimate of truth and the
653* estimated RCOND may be too optimistic. To avoid misleading users,
654* the inverse condition number is set to 0.0 when the estimated
655* cwise error is at least CWISE_WRONG.
656*
657 cwise_wrong = sqrt( slamch( 'Epsilon' ) )
658 DO j = 1, nrhs
659 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
660 $ THEN
661 rcond_tmp = cla_syrcond_x( uplo, n, a, lda, af, ldaf,
662 $ ipiv, x(1,j), info, work, rwork )
663 ELSE
664 rcond_tmp = 0.0
665 END IF
666*
667* Cap the error at 1.0.
668*
669 IF ( n_err_bnds .GE. la_linrx_err_i
670 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
671 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
672
673*
674* Threshold the error (see LAWN).
675*
676 IF ( rcond_tmp .LT. illrcond_thresh ) THEN
677 err_bnds_comp( j, la_linrx_err_i ) = 1.0
678 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
679 IF ( .NOT. ignore_cwise
680 $ .AND. info.LT.n + j ) info = n + j
681 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
682 $ .LT. err_lbnd ) THEN
683 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
684 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
685 END IF
686*
687* Save the condition number.
688*
689 IF ( n_err_bnds .GE. la_linrx_rcond_i ) THEN
690 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
691 END IF
692
693 END DO
694 END IF
695*
696 RETURN
697*
698* End of CSYRFSX
699*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
ilaprec
integer function ilaprec(prec)
ILAPREC
Definition ilaprec.f:58
clansy
real function clansy(norm, uplo, n, a, lda, work)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clansy.f:123
csycon
subroutine csycon(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CSYCON
Definition csycon.f:125
cla_syrfsx_extended
subroutine cla_syrfsx_extended(prec_type, uplo, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
CLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric inde...
Definition cla_syrfsx_extended.f:395

◆ csysv_aa_2stage()

subroutine csysv_aa_2stage ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
integer lwork,
integer info )

CSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices

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

Purpose:
!>
!> CSYSV_AA_2STAGE computes the solution to a complex system of
!> linear equations
!>    A * X = B,
!> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!> matrices.
!>
!> Aasen's 2-stage algorithm is used to factor A as
!>    A = U**T * T * U,  if UPLO = 'U', or
!>    A = L * T * L**T,  if UPLO = 'L',
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is symmetric and band. The matrix T is
!> then LU-factored with partial pivoting. The factored form of A
!> is then used to solve the system of equations A * X = B.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, L is stored below (or above) the subdiaonal blocks,
!>          when UPLO  is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX array, dimension (LTB)
!>          On exit, details of the LU factorization of the band matrix.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N, internally
!>          used to select NB such that LTB >= (3*NB+1)*N.
!>
!>          If LTB = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of LTB, 
!>          returns this value as the first entry of TB, and
!>          no error message related to LTB is issued by XERBLA.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of T were interchanged with the
!>          row and column IPIV(k).
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX workspace of size LWORK
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The size of WORK. LWORK >= N, internally used to select NB
!>          such that LWORK >= N*NB.
!>
!>          If LWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the WORK array,
!>          returns this value as the first entry of the WORK array, and
!>          no error message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, band LU factorization failed on i-th column
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 183 of file csysv_aa_2stage.f.

186*
187* -- LAPACK computational routine --
188* -- LAPACK is a software package provided by Univ. of Tennessee, --
189* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
190*
191 IMPLICIT NONE
192*
193* .. Scalar Arguments ..
194 CHARACTER UPLO
195 INTEGER N, NRHS, LDA, LDB, LTB, LWORK, INFO
196* ..
197* .. Array Arguments ..
198 INTEGER IPIV( * ), IPIV2( * )
199 COMPLEX A( LDA, * ), B( LDB, * ), TB( * ), WORK( * )
200* ..
201*
202* =====================================================================
203*
204* .. Local Scalars ..
205 LOGICAL UPPER, TQUERY, WQUERY
206 INTEGER LWKOPT
207* ..
208* .. External Functions ..
209 LOGICAL LSAME
210 EXTERNAL lsame
211* ..
212* .. External Subroutines ..
213 EXTERNAL csytrf_aa_2stage,
214 $ csytrs_aa_2stage, xerbla
215* ..
216* .. Intrinsic Functions ..
217 INTRINSIC max
218* ..
219* .. Executable Statements ..
220*
221* Test the input parameters.
222*
223 info = 0
224 upper = lsame( uplo, 'U' )
225 wquery = ( lwork.EQ.-1 )
226 tquery = ( ltb.EQ.-1 )
227 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
228 info = -1
229 ELSE IF( n.LT.0 ) THEN
230 info = -2
231 ELSE IF( nrhs.LT.0 ) THEN
232 info = -3
233 ELSE IF( lda.LT.max( 1, n ) ) THEN
234 info = -5
235 ELSE IF( ltb.LT.( 4*n ) .AND. .NOT.tquery ) THEN
236 info = -7
237 ELSE IF( ldb.LT.max( 1, n ) ) THEN
238 info = -11
239 ELSE IF( lwork.LT.n .AND. .NOT.wquery ) THEN
240 info = -13
241 END IF
242*
243 IF( info.EQ.0 ) THEN
244 CALL csytrf_aa_2stage( uplo, n, a, lda, tb, -1, ipiv,
245 $ ipiv2, work, -1, info )
246 lwkopt = int( work(1) )
247 END IF
248*
249 IF( info.NE.0 ) THEN
250 CALL xerbla( 'CSYSV_AA_2STAGE', -info )
251 RETURN
252 ELSE IF( wquery .OR. tquery ) THEN
253 RETURN
254 END IF
255*
256*
257* Compute the factorization A = U**T*T*U or A = L*T*L**T.
258*
259 CALL csytrf_aa_2stage( uplo, n, a, lda, tb, ltb, ipiv, ipiv2,
260 $ work, lwork, info )
261 IF( info.EQ.0 ) THEN
262*
263* Solve the system A*X = B, overwriting B with X.
264*
265 CALL csytrs_aa_2stage( uplo, n, nrhs, a, lda, tb, ltb, ipiv,
266 $ ipiv2, b, ldb, info )
267*
268 END IF
269*
270 work( 1 ) = lwkopt
271*
272 RETURN
273*
274* End of CSYSV_AA_2STAGE
275*
csytrf_aa_2stage
subroutine csytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
CSYTRF_AA_2STAGE
Definition csytrf_aa_2stage.f:160
csytrs_aa_2stage
subroutine csytrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
CSYTRS_AA_2STAGE
Definition csytrs_aa_2stage.f:139

◆ csytf2()

subroutine csytf2 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

CSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).

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

Purpose:
!>
!> CSYTF2 computes the factorization of a complex symmetric matrix A
!> using the Bunch-Kaufman diagonal pivoting method:
!>
!>    A = U*D*U**T  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, U**T is the transpose of U, and D is symmetric and
!> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This is the unblocked version of the algorithm, calling Level 2 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L (see below for further details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>
!>          If UPLO = 'U':
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>             interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) = IPIV(k-1) < 0, then rows and columns
!>             k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!>             is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>             interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) = IPIV(k+1) < 0, then rows and columns
!>             k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
!>             is a 2-by-2 diagonal block.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
!>               has been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if it
!>               is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', then A = U*D*U**T, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>
Contributors:
!>
!>  09-29-06 - patch from
!>    Bobby Cheng, MathWorks
!>
!>    Replace l.209 and l.377
!>         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!>    by
!>         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
!>
!>  1-96 - Based on modifications by J. Lewis, Boeing Computer Services
!>         Company
!>

Definition at line 190 of file csytf2.f.

191*
192* -- LAPACK computational routine --
193* -- LAPACK is a software package provided by Univ. of Tennessee, --
194* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
195*
196* .. Scalar Arguments ..
197 CHARACTER UPLO
198 INTEGER INFO, LDA, N
199* ..
200* .. Array Arguments ..
201 INTEGER IPIV( * )
202 COMPLEX A( LDA, * )
203* ..
204*
205* =====================================================================
206*
207* .. Parameters ..
208 REAL ZERO, ONE
209 parameter( zero = 0.0e+0, one = 1.0e+0 )
210 REAL EIGHT, SEVTEN
211 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
212 COMPLEX CONE
213 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
214* ..
215* .. Local Scalars ..
216 LOGICAL UPPER
217 INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
218 REAL ABSAKK, ALPHA, COLMAX, ROWMAX
219 COMPLEX D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z
220* ..
221* .. External Functions ..
222 LOGICAL LSAME, SISNAN
223 INTEGER ICAMAX
224 EXTERNAL lsame, icamax, sisnan
225* ..
226* .. External Subroutines ..
227 EXTERNAL cscal, cswap, csyr, xerbla
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC abs, aimag, max, real, sqrt
231* ..
232* .. Statement Functions ..
233 REAL CABS1
234* ..
235* .. Statement Function definitions ..
236 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
237* ..
238* .. Executable Statements ..
239*
240* Test the input parameters.
241*
242 info = 0
243 upper = lsame( uplo, 'U' )
244 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
245 info = -1
246 ELSE IF( n.LT.0 ) THEN
247 info = -2
248 ELSE IF( lda.LT.max( 1, n ) ) THEN
249 info = -4
250 END IF
251 IF( info.NE.0 ) THEN
252 CALL xerbla( 'CSYTF2', -info )
253 RETURN
254 END IF
255*
256* Initialize ALPHA for use in choosing pivot block size.
257*
258 alpha = ( one+sqrt( sevten ) ) / eight
259*
260 IF( upper ) THEN
261*
262* Factorize A as U*D*U**T using the upper triangle of A
263*
264* K is the main loop index, decreasing from N to 1 in steps of
265* 1 or 2
266*
267 k = n
268 10 CONTINUE
269*
270* If K < 1, exit from loop
271*
272 IF( k.LT.1 )
273 $ GO TO 70
274 kstep = 1
275*
276* Determine rows and columns to be interchanged and whether
277* a 1-by-1 or 2-by-2 pivot block will be used
278*
279 absakk = cabs1( a( k, k ) )
280*
281* IMAX is the row-index of the largest off-diagonal element in
282* column K, and COLMAX is its absolute value.
283* Determine both COLMAX and IMAX.
284*
285 IF( k.GT.1 ) THEN
286 imax = icamax( k-1, a( 1, k ), 1 )
287 colmax = cabs1( a( imax, k ) )
288 ELSE
289 colmax = zero
290 END IF
291*
292 IF( max( absakk, colmax ).EQ.zero .OR. sisnan(absakk) ) THEN
293*
294* Column K is zero or underflow, or contains a NaN:
295* set INFO and continue
296*
297 IF( info.EQ.0 )
298 $ info = k
299 kp = k
300 ELSE
301 IF( absakk.GE.alpha*colmax ) THEN
302*
303* no interchange, use 1-by-1 pivot block
304*
305 kp = k
306 ELSE
307*
308* JMAX is the column-index of the largest off-diagonal
309* element in row IMAX, and ROWMAX is its absolute value
310*
311 jmax = imax + icamax( k-imax, a( imax, imax+1 ), lda )
312 rowmax = cabs1( a( imax, jmax ) )
313 IF( imax.GT.1 ) THEN
314 jmax = icamax( imax-1, a( 1, imax ), 1 )
315 rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
316 END IF
317*
318 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
319*
320* no interchange, use 1-by-1 pivot block
321*
322 kp = k
323 ELSE IF( cabs1( a( imax, imax ) ).GE.alpha*rowmax ) THEN
324*
325* interchange rows and columns K and IMAX, use 1-by-1
326* pivot block
327*
328 kp = imax
329 ELSE
330*
331* interchange rows and columns K-1 and IMAX, use 2-by-2
332* pivot block
333*
334 kp = imax
335 kstep = 2
336 END IF
337 END IF
338*
339 kk = k - kstep + 1
340 IF( kp.NE.kk ) THEN
341*
342* Interchange rows and columns KK and KP in the leading
343* submatrix A(1:k,1:k)
344*
345 CALL cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
346 CALL cswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),
347 $ lda )
348 t = a( kk, kk )
349 a( kk, kk ) = a( kp, kp )
350 a( kp, kp ) = t
351 IF( kstep.EQ.2 ) THEN
352 t = a( k-1, k )
353 a( k-1, k ) = a( kp, k )
354 a( kp, k ) = t
355 END IF
356 END IF
357*
358* Update the leading submatrix
359*
360 IF( kstep.EQ.1 ) THEN
361*
362* 1-by-1 pivot block D(k): column k now holds
363*
364* W(k) = U(k)*D(k)
365*
366* where U(k) is the k-th column of U
367*
368* Perform a rank-1 update of A(1:k-1,1:k-1) as
369*
370* A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T
371*
372 r1 = cone / a( k, k )
373 CALL csyr( uplo, k-1, -r1, a( 1, k ), 1, a, lda )
374*
375* Store U(k) in column k
376*
377 CALL cscal( k-1, r1, a( 1, k ), 1 )
378 ELSE
379*
380* 2-by-2 pivot block D(k): columns k and k-1 now hold
381*
382* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
383*
384* where U(k) and U(k-1) are the k-th and (k-1)-th columns
385* of U
386*
387* Perform a rank-2 update of A(1:k-2,1:k-2) as
388*
389* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
390* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T
391*
392 IF( k.GT.2 ) THEN
393*
394 d12 = a( k-1, k )
395 d22 = a( k-1, k-1 ) / d12
396 d11 = a( k, k ) / d12
397 t = cone / ( d11*d22-cone )
398 d12 = t / d12
399*
400 DO 30 j = k - 2, 1, -1
401 wkm1 = d12*( d11*a( j, k-1 )-a( j, k ) )
402 wk = d12*( d22*a( j, k )-a( j, k-1 ) )
403 DO 20 i = j, 1, -1
404 a( i, j ) = a( i, j ) - a( i, k )*wk -
405 $ a( i, k-1 )*wkm1
406 20 CONTINUE
407 a( j, k ) = wk
408 a( j, k-1 ) = wkm1
409 30 CONTINUE
410*
411 END IF
412*
413 END IF
414 END IF
415*
416* Store details of the interchanges in IPIV
417*
418 IF( kstep.EQ.1 ) THEN
419 ipiv( k ) = kp
420 ELSE
421 ipiv( k ) = -kp
422 ipiv( k-1 ) = -kp
423 END IF
424*
425* Decrease K and return to the start of the main loop
426*
427 k = k - kstep
428 GO TO 10
429*
430 ELSE
431*
432* Factorize A as L*D*L**T using the lower triangle of A
433*
434* K is the main loop index, increasing from 1 to N in steps of
435* 1 or 2
436*
437 k = 1
438 40 CONTINUE
439*
440* If K > N, exit from loop
441*
442 IF( k.GT.n )
443 $ GO TO 70
444 kstep = 1
445*
446* Determine rows and columns to be interchanged and whether
447* a 1-by-1 or 2-by-2 pivot block will be used
448*
449 absakk = cabs1( a( k, k ) )
450*
451* IMAX is the row-index of the largest off-diagonal element in
452* column K, and COLMAX is its absolute value.
453* Determine both COLMAX and IMAX.
454*
455 IF( k.LT.n ) THEN
456 imax = k + icamax( n-k, a( k+1, k ), 1 )
457 colmax = cabs1( a( imax, k ) )
458 ELSE
459 colmax = zero
460 END IF
461*
462 IF( max( absakk, colmax ).EQ.zero .OR. sisnan(absakk) ) THEN
463*
464* Column K is zero or underflow, or contains a NaN:
465* set INFO and continue
466*
467 IF( info.EQ.0 )
468 $ info = k
469 kp = k
470 ELSE
471 IF( absakk.GE.alpha*colmax ) THEN
472*
473* no interchange, use 1-by-1 pivot block
474*
475 kp = k
476 ELSE
477*
478* JMAX is the column-index of the largest off-diagonal
479* element in row IMAX, and ROWMAX is its absolute value
480*
481 jmax = k - 1 + icamax( imax-k, a( imax, k ), lda )
482 rowmax = cabs1( a( imax, jmax ) )
483 IF( imax.LT.n ) THEN
484 jmax = imax + icamax( n-imax, a( imax+1, imax ), 1 )
485 rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
486 END IF
487*
488 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
489*
490* no interchange, use 1-by-1 pivot block
491*
492 kp = k
493 ELSE IF( cabs1( a( imax, imax ) ).GE.alpha*rowmax ) THEN
494*
495* interchange rows and columns K and IMAX, use 1-by-1
496* pivot block
497*
498 kp = imax
499 ELSE
500*
501* interchange rows and columns K+1 and IMAX, use 2-by-2
502* pivot block
503*
504 kp = imax
505 kstep = 2
506 END IF
507 END IF
508*
509 kk = k + kstep - 1
510 IF( kp.NE.kk ) THEN
511*
512* Interchange rows and columns KK and KP in the trailing
513* submatrix A(k:n,k:n)
514*
515 IF( kp.LT.n )
516 $ CALL cswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
517 CALL cswap( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
518 $ lda )
519 t = a( kk, kk )
520 a( kk, kk ) = a( kp, kp )
521 a( kp, kp ) = t
522 IF( kstep.EQ.2 ) THEN
523 t = a( k+1, k )
524 a( k+1, k ) = a( kp, k )
525 a( kp, k ) = t
526 END IF
527 END IF
528*
529* Update the trailing submatrix
530*
531 IF( kstep.EQ.1 ) THEN
532*
533* 1-by-1 pivot block D(k): column k now holds
534*
535* W(k) = L(k)*D(k)
536*
537* where L(k) is the k-th column of L
538*
539 IF( k.LT.n ) THEN
540*
541* Perform a rank-1 update of A(k+1:n,k+1:n) as
542*
543* A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T
544*
545 r1 = cone / a( k, k )
546 CALL csyr( uplo, n-k, -r1, a( k+1, k ), 1,
547 $ a( k+1, k+1 ), lda )
548*
549* Store L(k) in column K
550*
551 CALL cscal( n-k, r1, a( k+1, k ), 1 )
552 END IF
553 ELSE
554*
555* 2-by-2 pivot block D(k)
556*
557 IF( k.LT.n-1 ) THEN
558*
559* Perform a rank-2 update of A(k+2:n,k+2:n) as
560*
561* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T
562* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T
563*
564* where L(k) and L(k+1) are the k-th and (k+1)-th
565* columns of L
566*
567 d21 = a( k+1, k )
568 d11 = a( k+1, k+1 ) / d21
569 d22 = a( k, k ) / d21
570 t = cone / ( d11*d22-cone )
571 d21 = t / d21
572*
573 DO 60 j = k + 2, n
574 wk = d21*( d11*a( j, k )-a( j, k+1 ) )
575 wkp1 = d21*( d22*a( j, k+1 )-a( j, k ) )
576 DO 50 i = j, n
577 a( i, j ) = a( i, j ) - a( i, k )*wk -
578 $ a( i, k+1 )*wkp1
579 50 CONTINUE
580 a( j, k ) = wk
581 a( j, k+1 ) = wkp1
582 60 CONTINUE
583 END IF
584 END IF
585 END IF
586*
587* Store details of the interchanges in IPIV
588*
589 IF( kstep.EQ.1 ) THEN
590 ipiv( k ) = kp
591 ELSE
592 ipiv( k ) = -kp
593 ipiv( k+1 ) = -kp
594 END IF
595*
596* Increase K and return to the start of the main loop
597*
598 k = k + kstep
599 GO TO 40
600*
601 END IF
602*
603 70 CONTINUE
604 RETURN
605*
606* End of CSYTF2
607*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
csyr
subroutine csyr(uplo, n, alpha, x, incx, a, lda)
CSYR performs the symmetric rank-1 update of a complex symmetric matrix.
Definition csyr.f:135

◆ csytf2_rk()

subroutine csytf2_rk ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
integer info )

CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).

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

Purpose:
!> CSYTF2_RK computes the factorization of a complex symmetric matrix A
!> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!>
!>    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 unblocked version of the algorithm, calling Level 2 BLAS.
!> For more information see Further Details section.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.
!>            If UPLO = 'U': the leading N-by-N upper triangular part
!>            of A contains the upper triangular part of the matrix A,
!>            and the strictly lower triangular part of A is not
!>            referenced.
!>
!>            If UPLO = 'L': the leading N-by-N lower triangular part
!>            of A contains the lower triangular part of the matrix A,
!>            and the strictly upper triangular part of A is not
!>            referenced.
!>
!>          On exit, contains:
!>            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
!>                are stored on exit 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]E
!>          E is COMPLEX array, dimension (N)
!>          On exit, 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) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is set to 0 in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          IPIV describes the permutation matrix P in the factorization
!>          of matrix A as follows. The absolute value of IPIV(k)
!>          represents the index of row and column that were
!>          interchanged with the k-th row and column. The value of UPLO
!>          describes the order in which the interchanges were applied.
!>          Also, the sign of IPIV represents the block structure of
!>          the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
!>          diagonal blocks which correspond to 1 or 2 interchanges
!>          at each factorization step. For more info see Further
!>          Details section.
!>
!>          If UPLO = 'U',
!>          ( in factorization order, k decreases from N to 1 ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the matrix A(1:N,1:N);
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k-1) < 0 means:
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k-1) != k-1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k-1) = k-1, no interchange occurred.
!>
!>            c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
!>          If UPLO = 'L',
!>          ( in factorization order, k increases from 1 to N ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the matrix A(1:N,1:N).
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k+1) < 0 means:
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k+1) != k+1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k+1) = k+1, no interchange occurred.
!>
!>            c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>
!>          < 0: If INFO = -k, the k-th argument had an illegal value
!>
!>          > 0: If INFO = k, the matrix A is singular, because:
!>                 If UPLO = 'U': column k in the upper
!>                 triangular part of A contains all zeros.
!>                 If UPLO = 'L': column k in the lower
!>                 triangular part of A contains all zeros.
!>
!>               Therefore D(k,k) is exactly zero, and superdiagonal
!>               elements of column k of U (or subdiagonal elements of
!>               column k of L ) are all zeros. The factorization has
!>               been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if
!>               it is used to solve a system of equations.
!>
!>               NOTE: INFO only stores the first occurrence of
!>               a singularity, any subsequent occurrence of singularity
!>               is not stored in INFO even though the factorization
!>               always completes.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!> TODO: put further details
!>
Contributors:
!>
!>  December 2016,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!>  01-01-96 - Based on modifications by
!>    J. Lewis, Boeing Computer Services Company
!>    A. Petitet, Computer Science Dept.,
!>                Univ. of Tenn., Knoxville abd , USA
!>

Definition at line 240 of file csytf2_rk.f.

241*
242* -- LAPACK computational routine --
243* -- LAPACK is a software package provided by Univ. of Tennessee, --
244* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
245*
246* .. Scalar Arguments ..
247 CHARACTER UPLO
248 INTEGER INFO, LDA, N
249* ..
250* .. Array Arguments ..
251 INTEGER IPIV( * )
252 COMPLEX A( LDA, * ), E( * )
253* ..
254*
255* =====================================================================
256*
257* .. Parameters ..
258 REAL ZERO, ONE
259 parameter( zero = 0.0e+0, one = 1.0e+0 )
260 REAL EIGHT, SEVTEN
261 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
262 COMPLEX CONE, CZERO
263 parameter( cone = ( 1.0e+0, 0.0e+0 ),
264 $ czero = ( 0.0e+0, 0.0e+0 ) )
265* ..
266* .. Local Scalars ..
267 LOGICAL UPPER, DONE
268 INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
269 $ P, II
270 REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
271 COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
272* ..
273* .. External Functions ..
274 LOGICAL LSAME
275 INTEGER ICAMAX
276 REAL SLAMCH
277 EXTERNAL lsame, icamax, slamch
278* ..
279* .. External Subroutines ..
280 EXTERNAL cscal, cswap, csyr, xerbla
281* ..
282* .. Intrinsic Functions ..
283 INTRINSIC abs, max, sqrt, aimag, real
284* ..
285* .. Statement Functions ..
286 REAL CABS1
287* ..
288* .. Statement Function definitions ..
289 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
290* ..
291* .. Executable Statements ..
292*
293* Test the input parameters.
294*
295 info = 0
296 upper = lsame( uplo, 'U' )
297 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
298 info = -1
299 ELSE IF( n.LT.0 ) THEN
300 info = -2
301 ELSE IF( lda.LT.max( 1, n ) ) THEN
302 info = -4
303 END IF
304 IF( info.NE.0 ) THEN
305 CALL xerbla( 'CSYTF2_RK', -info )
306 RETURN
307 END IF
308*
309* Initialize ALPHA for use in choosing pivot block size.
310*
311 alpha = ( one+sqrt( sevten ) ) / eight
312*
313* Compute machine safe minimum
314*
315 sfmin = slamch( 'S' )
316*
317 IF( upper ) THEN
318*
319* Factorize A as U*D*U**T using the upper triangle of A
320*
321* Initialize the first entry of array E, where superdiagonal
322* elements of D are stored
323*
324 e( 1 ) = czero
325*
326* K is the main loop index, decreasing from N to 1 in steps of
327* 1 or 2
328*
329 k = n
330 10 CONTINUE
331*
332* If K < 1, exit from loop
333*
334 IF( k.LT.1 )
335 $ GO TO 34
336 kstep = 1
337 p = k
338*
339* Determine rows and columns to be interchanged and whether
340* a 1-by-1 or 2-by-2 pivot block will be used
341*
342 absakk = cabs1( a( k, k ) )
343*
344* IMAX is the row-index of the largest off-diagonal element in
345* column K, and COLMAX is its absolute value.
346* Determine both COLMAX and IMAX.
347*
348 IF( k.GT.1 ) THEN
349 imax = icamax( k-1, a( 1, k ), 1 )
350 colmax = cabs1( a( imax, k ) )
351 ELSE
352 colmax = zero
353 END IF
354*
355 IF( (max( absakk, colmax ).EQ.zero) ) THEN
356*
357* Column K is zero or underflow: set INFO and continue
358*
359 IF( info.EQ.0 )
360 $ info = k
361 kp = k
362*
363* Set E( K ) to zero
364*
365 IF( k.GT.1 )
366 $ e( k ) = czero
367*
368 ELSE
369*
370* Test for interchange
371*
372* Equivalent to testing for (used to handle NaN and Inf)
373* ABSAKK.GE.ALPHA*COLMAX
374*
375 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
376*
377* no interchange,
378* use 1-by-1 pivot block
379*
380 kp = k
381 ELSE
382*
383 done = .false.
384*
385* Loop until pivot found
386*
387 12 CONTINUE
388*
389* Begin pivot search loop body
390*
391* JMAX is the column-index of the largest off-diagonal
392* element in row IMAX, and ROWMAX is its absolute value.
393* Determine both ROWMAX and JMAX.
394*
395 IF( imax.NE.k ) THEN
396 jmax = imax + icamax( k-imax, a( imax, imax+1 ),
397 $ lda )
398 rowmax = cabs1( a( imax, jmax ) )
399 ELSE
400 rowmax = zero
401 END IF
402*
403 IF( imax.GT.1 ) THEN
404 itemp = icamax( imax-1, a( 1, imax ), 1 )
405 stemp = cabs1( a( itemp, imax ) )
406 IF( stemp.GT.rowmax ) THEN
407 rowmax = stemp
408 jmax = itemp
409 END IF
410 END IF
411*
412* Equivalent to testing for (used to handle NaN and Inf)
413* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
414*
415 IF( .NOT.( cabs1( a( imax, imax ) ).LT.alpha*rowmax ))
416 $ THEN
417*
418* interchange rows and columns K and IMAX,
419* use 1-by-1 pivot block
420*
421 kp = imax
422 done = .true.
423*
424* Equivalent to testing for ROWMAX .EQ. COLMAX,
425* used to handle NaN and Inf
426*
427 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) ) THEN
428*
429* interchange rows and columns K+1 and IMAX,
430* use 2-by-2 pivot block
431*
432 kp = imax
433 kstep = 2
434 done = .true.
435 ELSE
436*
437* Pivot NOT found, set variables and repeat
438*
439 p = imax
440 colmax = rowmax
441 imax = jmax
442 END IF
443*
444* End pivot search loop body
445*
446 IF( .NOT. done ) GOTO 12
447*
448 END IF
449*
450* Swap TWO rows and TWO columns
451*
452* First swap
453*
454 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
455*
456* Interchange rows and column K and P in the leading
457* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
458*
459 IF( p.GT.1 )
460 $ CALL cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
461 IF( p.LT.(k-1) )
462 $ CALL cswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),
463 $ lda )
464 t = a( k, k )
465 a( k, k ) = a( p, p )
466 a( p, p ) = t
467*
468* Convert upper triangle of A into U form by applying
469* the interchanges in columns k+1:N.
470*
471 IF( k.LT.n )
472 $ CALL cswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
473*
474 END IF
475*
476* Second swap
477*
478 kk = k - kstep + 1
479 IF( kp.NE.kk ) THEN
480*
481* Interchange rows and columns KK and KP in the leading
482* submatrix A(1:k,1:k)
483*
484 IF( kp.GT.1 )
485 $ CALL cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
486 IF( ( kk.GT.1 ) .AND. ( kp.LT.(kk-1) ) )
487 $ CALL cswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),
488 $ lda )
489 t = a( kk, kk )
490 a( kk, kk ) = a( kp, kp )
491 a( kp, kp ) = t
492 IF( kstep.EQ.2 ) THEN
493 t = a( k-1, k )
494 a( k-1, k ) = a( kp, k )
495 a( kp, k ) = t
496 END IF
497*
498* Convert upper triangle of A into U form by applying
499* the interchanges in columns k+1:N.
500*
501 IF( k.LT.n )
502 $ CALL cswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
503 $ lda )
504*
505 END IF
506*
507* Update the leading submatrix
508*
509 IF( kstep.EQ.1 ) THEN
510*
511* 1-by-1 pivot block D(k): column k now holds
512*
513* W(k) = U(k)*D(k)
514*
515* where U(k) is the k-th column of U
516*
517 IF( k.GT.1 ) THEN
518*
519* Perform a rank-1 update of A(1:k-1,1:k-1) and
520* store U(k) in column k
521*
522 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
523*
524* Perform a rank-1 update of A(1:k-1,1:k-1) as
525* A := A - U(k)*D(k)*U(k)**T
526* = A - W(k)*1/D(k)*W(k)**T
527*
528 d11 = cone / a( k, k )
529 CALL csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
530*
531* Store U(k) in column k
532*
533 CALL cscal( k-1, d11, a( 1, k ), 1 )
534 ELSE
535*
536* Store L(k) in column K
537*
538 d11 = a( k, k )
539 DO 16 ii = 1, k - 1
540 a( ii, k ) = a( ii, k ) / d11
541 16 CONTINUE
542*
543* Perform a rank-1 update of A(k+1:n,k+1:n) as
544* A := A - U(k)*D(k)*U(k)**T
545* = A - W(k)*(1/D(k))*W(k)**T
546* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
547*
548 CALL csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
549 END IF
550*
551* Store the superdiagonal element of D in array E
552*
553 e( k ) = czero
554*
555 END IF
556*
557 ELSE
558*
559* 2-by-2 pivot block D(k): columns k and k-1 now hold
560*
561* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
562*
563* where U(k) and U(k-1) are the k-th and (k-1)-th columns
564* of U
565*
566* Perform a rank-2 update of A(1:k-2,1:k-2) as
567*
568* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
569* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
570*
571* and store L(k) and L(k+1) in columns k and k+1
572*
573 IF( k.GT.2 ) THEN
574*
575 d12 = a( k-1, k )
576 d22 = a( k-1, k-1 ) / d12
577 d11 = a( k, k ) / d12
578 t = cone / ( d11*d22-cone )
579*
580 DO 30 j = k - 2, 1, -1
581*
582 wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
583 wk = t*( d22*a( j, k )-a( j, k-1 ) )
584*
585 DO 20 i = j, 1, -1
586 a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -
587 $ ( a( i, k-1 ) / d12 )*wkm1
588 20 CONTINUE
589*
590* Store U(k) and U(k-1) in cols k and k-1 for row J
591*
592 a( j, k ) = wk / d12
593 a( j, k-1 ) = wkm1 / d12
594*
595 30 CONTINUE
596*
597 END IF
598*
599* Copy superdiagonal elements of D(K) to E(K) and
600* ZERO out superdiagonal entry of A
601*
602 e( k ) = a( k-1, k )
603 e( k-1 ) = czero
604 a( k-1, k ) = czero
605*
606 END IF
607*
608* End column K is nonsingular
609*
610 END IF
611*
612* Store details of the interchanges in IPIV
613*
614 IF( kstep.EQ.1 ) THEN
615 ipiv( k ) = kp
616 ELSE
617 ipiv( k ) = -p
618 ipiv( k-1 ) = -kp
619 END IF
620*
621* Decrease K and return to the start of the main loop
622*
623 k = k - kstep
624 GO TO 10
625*
626 34 CONTINUE
627*
628 ELSE
629*
630* Factorize A as L*D*L**T using the lower triangle of A
631*
632* Initialize the unused last entry of the subdiagonal array E.
633*
634 e( n ) = czero
635*
636* K is the main loop index, increasing from 1 to N in steps of
637* 1 or 2
638*
639 k = 1
640 40 CONTINUE
641*
642* If K > N, exit from loop
643*
644 IF( k.GT.n )
645 $ GO TO 64
646 kstep = 1
647 p = k
648*
649* Determine rows and columns to be interchanged and whether
650* a 1-by-1 or 2-by-2 pivot block will be used
651*
652 absakk = cabs1( a( k, k ) )
653*
654* IMAX is the row-index of the largest off-diagonal element in
655* column K, and COLMAX is its absolute value.
656* Determine both COLMAX and IMAX.
657*
658 IF( k.LT.n ) THEN
659 imax = k + icamax( n-k, a( k+1, k ), 1 )
660 colmax = cabs1( a( imax, k ) )
661 ELSE
662 colmax = zero
663 END IF
664*
665 IF( ( max( absakk, colmax ).EQ.zero ) ) THEN
666*
667* Column K is zero or underflow: set INFO and continue
668*
669 IF( info.EQ.0 )
670 $ info = k
671 kp = k
672*
673* Set E( K ) to zero
674*
675 IF( k.LT.n )
676 $ e( k ) = czero
677*
678 ELSE
679*
680* Test for interchange
681*
682* Equivalent to testing for (used to handle NaN and Inf)
683* ABSAKK.GE.ALPHA*COLMAX
684*
685 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
686*
687* no interchange, use 1-by-1 pivot block
688*
689 kp = k
690*
691 ELSE
692*
693 done = .false.
694*
695* Loop until pivot found
696*
697 42 CONTINUE
698*
699* Begin pivot search loop body
700*
701* JMAX is the column-index of the largest off-diagonal
702* element in row IMAX, and ROWMAX is its absolute value.
703* Determine both ROWMAX and JMAX.
704*
705 IF( imax.NE.k ) THEN
706 jmax = k - 1 + icamax( imax-k, a( imax, k ), lda )
707 rowmax = cabs1( a( imax, jmax ) )
708 ELSE
709 rowmax = zero
710 END IF
711*
712 IF( imax.LT.n ) THEN
713 itemp = imax + icamax( n-imax, a( imax+1, imax ),
714 $ 1 )
715 stemp = cabs1( a( itemp, imax ) )
716 IF( stemp.GT.rowmax ) THEN
717 rowmax = stemp
718 jmax = itemp
719 END IF
720 END IF
721*
722* Equivalent to testing for (used to handle NaN and Inf)
723* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
724*
725 IF( .NOT.( cabs1( a( imax, imax ) ).LT.alpha*rowmax ))
726 $ THEN
727*
728* interchange rows and columns K and IMAX,
729* use 1-by-1 pivot block
730*
731 kp = imax
732 done = .true.
733*
734* Equivalent to testing for ROWMAX .EQ. COLMAX,
735* used to handle NaN and Inf
736*
737 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) ) THEN
738*
739* interchange rows and columns K+1 and IMAX,
740* use 2-by-2 pivot block
741*
742 kp = imax
743 kstep = 2
744 done = .true.
745 ELSE
746*
747* Pivot NOT found, set variables and repeat
748*
749 p = imax
750 colmax = rowmax
751 imax = jmax
752 END IF
753*
754* End pivot search loop body
755*
756 IF( .NOT. done ) GOTO 42
757*
758 END IF
759*
760* Swap TWO rows and TWO columns
761*
762* First swap
763*
764 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
765*
766* Interchange rows and column K and P in the trailing
767* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
768*
769 IF( p.LT.n )
770 $ CALL cswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
771 IF( p.GT.(k+1) )
772 $ CALL cswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda )
773 t = a( k, k )
774 a( k, k ) = a( p, p )
775 a( p, p ) = t
776*
777* Convert lower triangle of A into L form by applying
778* the interchanges in columns 1:k-1.
779*
780 IF ( k.GT.1 )
781 $ CALL cswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda )
782*
783 END IF
784*
785* Second swap
786*
787 kk = k + kstep - 1
788 IF( kp.NE.kk ) THEN
789*
790* Interchange rows and columns KK and KP in the trailing
791* submatrix A(k:n,k:n)
792*
793 IF( kp.LT.n )
794 $ CALL cswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
795 IF( ( kk.LT.n ) .AND. ( kp.GT.(kk+1) ) )
796 $ CALL cswap( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
797 $ lda )
798 t = a( kk, kk )
799 a( kk, kk ) = a( kp, kp )
800 a( kp, kp ) = t
801 IF( kstep.EQ.2 ) THEN
802 t = a( k+1, k )
803 a( k+1, k ) = a( kp, k )
804 a( kp, k ) = t
805 END IF
806*
807* Convert lower triangle of A into L form by applying
808* the interchanges in columns 1:k-1.
809*
810 IF ( k.GT.1 )
811 $ CALL cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
812*
813 END IF
814*
815* Update the trailing submatrix
816*
817 IF( kstep.EQ.1 ) THEN
818*
819* 1-by-1 pivot block D(k): column k now holds
820*
821* W(k) = L(k)*D(k)
822*
823* where L(k) is the k-th column of L
824*
825 IF( k.LT.n ) THEN
826*
827* Perform a rank-1 update of A(k+1:n,k+1:n) and
828* store L(k) in column k
829*
830 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
831*
832* Perform a rank-1 update of A(k+1:n,k+1:n) as
833* A := A - L(k)*D(k)*L(k)**T
834* = A - W(k)*(1/D(k))*W(k)**T
835*
836 d11 = cone / a( k, k )
837 CALL csyr( uplo, n-k, -d11, a( k+1, k ), 1,
838 $ a( k+1, k+1 ), lda )
839*
840* Store L(k) in column k
841*
842 CALL cscal( n-k, d11, a( k+1, k ), 1 )
843 ELSE
844*
845* Store L(k) in column k
846*
847 d11 = a( k, k )
848 DO 46 ii = k + 1, n
849 a( ii, k ) = a( ii, k ) / d11
850 46 CONTINUE
851*
852* Perform a rank-1 update of A(k+1:n,k+1:n) as
853* A := A - L(k)*D(k)*L(k)**T
854* = A - W(k)*(1/D(k))*W(k)**T
855* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
856*
857 CALL csyr( uplo, n-k, -d11, a( k+1, k ), 1,
858 $ a( k+1, k+1 ), lda )
859 END IF
860*
861* Store the subdiagonal element of D in array E
862*
863 e( k ) = czero
864*
865 END IF
866*
867 ELSE
868*
869* 2-by-2 pivot block D(k): columns k and k+1 now hold
870*
871* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
872*
873* where L(k) and L(k+1) are the k-th and (k+1)-th columns
874* of L
875*
876*
877* Perform a rank-2 update of A(k+2:n,k+2:n) as
878*
879* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
880* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
881*
882* and store L(k) and L(k+1) in columns k and k+1
883*
884 IF( k.LT.n-1 ) THEN
885*
886 d21 = a( k+1, k )
887 d11 = a( k+1, k+1 ) / d21
888 d22 = a( k, k ) / d21
889 t = cone / ( d11*d22-cone )
890*
891 DO 60 j = k + 2, n
892*
893* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
894*
895 wk = t*( d11*a( j, k )-a( j, k+1 ) )
896 wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
897*
898* Perform a rank-2 update of A(k+2:n,k+2:n)
899*
900 DO 50 i = j, n
901 a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -
902 $ ( a( i, k+1 ) / d21 )*wkp1
903 50 CONTINUE
904*
905* Store L(k) and L(k+1) in cols k and k+1 for row J
906*
907 a( j, k ) = wk / d21
908 a( j, k+1 ) = wkp1 / d21
909*
910 60 CONTINUE
911*
912 END IF
913*
914* Copy subdiagonal elements of D(K) to E(K) and
915* ZERO out subdiagonal entry of A
916*
917 e( k ) = a( k+1, k )
918 e( k+1 ) = czero
919 a( k+1, k ) = czero
920*
921 END IF
922*
923* End column K is nonsingular
924*
925 END IF
926*
927* Store details of the interchanges in IPIV
928*
929 IF( kstep.EQ.1 ) THEN
930 ipiv( k ) = kp
931 ELSE
932 ipiv( k ) = -p
933 ipiv( k+1 ) = -kp
934 END IF
935*
936* Increase K and return to the start of the main loop
937*
938 k = k + kstep
939 GO TO 40
940*
941 64 CONTINUE
942*
943 END IF
944*
945 RETURN
946*
947* End of CSYTF2_RK
948*

◆ csytf2_rook()

subroutine csytf2_rook ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).

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

Purpose:
!>
!> CSYTF2_ROOK computes the factorization of a complex symmetric matrix A
!> using the bounded Bunch-Kaufman () diagonal pivoting method:
!>
!>    A = U*D*U**T  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, U**T is the transpose of U, and D is symmetric and
!> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This is the unblocked version of the algorithm, calling Level 2 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L (see below for further details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>
!>          If UPLO = 'U':
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>             were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
!>             columns k and -IPIV(k) were interchanged and rows and
!>             columns k-1 and -IPIV(k-1) were inerchaged,
!>             D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>             were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
!>             columns k and -IPIV(k) were interchanged and rows and
!>             columns k+1 and -IPIV(k+1) were inerchaged,
!>             D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
!>               has been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if it
!>               is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', then A = U*D*U**T, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>
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
!>
!>  01-01-96 - Based on modifications by
!>    J. Lewis, Boeing Computer Services Company
!>    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA
!>

Definition at line 193 of file csytf2_rook.f.

194*
195* -- LAPACK computational routine --
196* -- LAPACK is a software package provided by Univ. of Tennessee, --
197* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
198*
199* .. Scalar Arguments ..
200 CHARACTER UPLO
201 INTEGER INFO, LDA, N
202* ..
203* .. Array Arguments ..
204 INTEGER IPIV( * )
205 COMPLEX A( LDA, * )
206* ..
207*
208* =====================================================================
209*
210* .. Parameters ..
211 REAL ZERO, ONE
212 parameter( zero = 0.0e+0, one = 1.0e+0 )
213 REAL EIGHT, SEVTEN
214 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
215 COMPLEX CONE
216 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
217* ..
218* .. Local Scalars ..
219 LOGICAL UPPER, DONE
220 INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
221 $ P, II
222 REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
223 COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 INTEGER ICAMAX
228 REAL SLAMCH
229 EXTERNAL lsame, icamax, slamch
230* ..
231* .. External Subroutines ..
232 EXTERNAL cscal, cswap, csyr, xerbla
233* ..
234* .. Intrinsic Functions ..
235 INTRINSIC abs, max, sqrt, aimag, real
236* ..
237* .. Statement Functions ..
238 REAL CABS1
239* ..
240* .. Statement Function definitions ..
241 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
242* ..
243* .. Executable Statements ..
244*
245* Test the input parameters.
246*
247 info = 0
248 upper = lsame( uplo, 'U' )
249 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
250 info = -1
251 ELSE IF( n.LT.0 ) THEN
252 info = -2
253 ELSE IF( lda.LT.max( 1, n ) ) THEN
254 info = -4
255 END IF
256 IF( info.NE.0 ) THEN
257 CALL xerbla( 'CSYTF2_ROOK', -info )
258 RETURN
259 END IF
260*
261* Initialize ALPHA for use in choosing pivot block size.
262*
263 alpha = ( one+sqrt( sevten ) ) / eight
264*
265* Compute machine safe minimum
266*
267 sfmin = slamch( 'S' )
268*
269 IF( upper ) THEN
270*
271* Factorize A as U*D*U**T using the upper triangle of A
272*
273* K is the main loop index, decreasing from N to 1 in steps of
274* 1 or 2
275*
276 k = n
277 10 CONTINUE
278*
279* If K < 1, exit from loop
280*
281 IF( k.LT.1 )
282 $ GO TO 70
283 kstep = 1
284 p = k
285*
286* Determine rows and columns to be interchanged and whether
287* a 1-by-1 or 2-by-2 pivot block will be used
288*
289 absakk = cabs1( a( k, k ) )
290*
291* IMAX is the row-index of the largest off-diagonal element in
292* column K, and COLMAX is its absolute value.
293* Determine both COLMAX and IMAX.
294*
295 IF( k.GT.1 ) THEN
296 imax = icamax( k-1, a( 1, k ), 1 )
297 colmax = cabs1( a( imax, k ) )
298 ELSE
299 colmax = zero
300 END IF
301*
302 IF( (max( absakk, colmax ).EQ.zero) ) THEN
303*
304* Column K is zero or underflow: set INFO and continue
305*
306 IF( info.EQ.0 )
307 $ info = k
308 kp = k
309 ELSE
310*
311* Test for interchange
312*
313* Equivalent to testing for (used to handle NaN and Inf)
314* ABSAKK.GE.ALPHA*COLMAX
315*
316 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
317*
318* no interchange,
319* use 1-by-1 pivot block
320*
321 kp = k
322 ELSE
323*
324 done = .false.
325*
326* Loop until pivot found
327*
328 12 CONTINUE
329*
330* Begin pivot search loop body
331*
332* JMAX is the column-index of the largest off-diagonal
333* element in row IMAX, and ROWMAX is its absolute value.
334* Determine both ROWMAX and JMAX.
335*
336 IF( imax.NE.k ) THEN
337 jmax = imax + icamax( k-imax, a( imax, imax+1 ),
338 $ lda )
339 rowmax = cabs1( a( imax, jmax ) )
340 ELSE
341 rowmax = zero
342 END IF
343*
344 IF( imax.GT.1 ) THEN
345 itemp = icamax( imax-1, a( 1, imax ), 1 )
346 stemp = cabs1( a( itemp, imax ) )
347 IF( stemp.GT.rowmax ) THEN
348 rowmax = stemp
349 jmax = itemp
350 END IF
351 END IF
352*
353* Equivalent to testing for (used to handle NaN and Inf)
354* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
355*
356 IF( .NOT.( cabs1(a( imax, imax )).LT.alpha*rowmax ) )
357 $ THEN
358*
359* interchange rows and columns K and IMAX,
360* use 1-by-1 pivot block
361*
362 kp = imax
363 done = .true.
364*
365* Equivalent to testing for ROWMAX .EQ. COLMAX,
366* used to handle NaN and Inf
367*
368 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) ) THEN
369*
370* interchange rows and columns K+1 and IMAX,
371* use 2-by-2 pivot block
372*
373 kp = imax
374 kstep = 2
375 done = .true.
376 ELSE
377*
378* Pivot NOT found, set variables and repeat
379*
380 p = imax
381 colmax = rowmax
382 imax = jmax
383 END IF
384*
385* End pivot search loop body
386*
387 IF( .NOT. done ) GOTO 12
388*
389 END IF
390*
391* Swap TWO rows and TWO columns
392*
393* First swap
394*
395 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
396*
397* Interchange rows and column K and P in the leading
398* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
399*
400 IF( p.GT.1 )
401 $ CALL cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
402 IF( p.LT.(k-1) )
403 $ CALL cswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),
404 $ lda )
405 t = a( k, k )
406 a( k, k ) = a( p, p )
407 a( p, p ) = t
408 END IF
409*
410* Second swap
411*
412 kk = k - kstep + 1
413 IF( kp.NE.kk ) THEN
414*
415* Interchange rows and columns KK and KP in the leading
416* submatrix A(1:k,1:k)
417*
418 IF( kp.GT.1 )
419 $ CALL cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
420 IF( ( kk.GT.1 ) .AND. ( kp.LT.(kk-1) ) )
421 $ CALL cswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),
422 $ lda )
423 t = a( kk, kk )
424 a( kk, kk ) = a( kp, kp )
425 a( kp, kp ) = t
426 IF( kstep.EQ.2 ) THEN
427 t = a( k-1, k )
428 a( k-1, k ) = a( kp, k )
429 a( kp, k ) = t
430 END IF
431 END IF
432*
433* Update the leading submatrix
434*
435 IF( kstep.EQ.1 ) THEN
436*
437* 1-by-1 pivot block D(k): column k now holds
438*
439* W(k) = U(k)*D(k)
440*
441* where U(k) is the k-th column of U
442*
443 IF( k.GT.1 ) THEN
444*
445* Perform a rank-1 update of A(1:k-1,1:k-1) and
446* store U(k) in column k
447*
448 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
449*
450* Perform a rank-1 update of A(1:k-1,1:k-1) as
451* A := A - U(k)*D(k)*U(k)**T
452* = A - W(k)*1/D(k)*W(k)**T
453*
454 d11 = cone / a( k, k )
455 CALL csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
456*
457* Store U(k) in column k
458*
459 CALL cscal( k-1, d11, a( 1, k ), 1 )
460 ELSE
461*
462* Store L(k) in column K
463*
464 d11 = a( k, k )
465 DO 16 ii = 1, k - 1
466 a( ii, k ) = a( ii, k ) / d11
467 16 CONTINUE
468*
469* Perform a rank-1 update of A(k+1:n,k+1:n) as
470* A := A - U(k)*D(k)*U(k)**T
471* = A - W(k)*(1/D(k))*W(k)**T
472* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
473*
474 CALL csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
475 END IF
476 END IF
477*
478 ELSE
479*
480* 2-by-2 pivot block D(k): columns k and k-1 now hold
481*
482* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
483*
484* where U(k) and U(k-1) are the k-th and (k-1)-th columns
485* of U
486*
487* Perform a rank-2 update of A(1:k-2,1:k-2) as
488*
489* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
490* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
491*
492* and store L(k) and L(k+1) in columns k and k+1
493*
494 IF( k.GT.2 ) THEN
495*
496 d12 = a( k-1, k )
497 d22 = a( k-1, k-1 ) / d12
498 d11 = a( k, k ) / d12
499 t = cone / ( d11*d22-cone )
500*
501 DO 30 j = k - 2, 1, -1
502*
503 wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
504 wk = t*( d22*a( j, k )-a( j, k-1 ) )
505*
506 DO 20 i = j, 1, -1
507 a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -
508 $ ( a( i, k-1 ) / d12 )*wkm1
509 20 CONTINUE
510*
511* Store U(k) and U(k-1) in cols k and k-1 for row J
512*
513 a( j, k ) = wk / d12
514 a( j, k-1 ) = wkm1 / d12
515*
516 30 CONTINUE
517*
518 END IF
519*
520 END IF
521 END IF
522*
523* Store details of the interchanges in IPIV
524*
525 IF( kstep.EQ.1 ) THEN
526 ipiv( k ) = kp
527 ELSE
528 ipiv( k ) = -p
529 ipiv( k-1 ) = -kp
530 END IF
531*
532* Decrease K and return to the start of the main loop
533*
534 k = k - kstep
535 GO TO 10
536*
537 ELSE
538*
539* Factorize A as L*D*L**T using the lower triangle of A
540*
541* K is the main loop index, increasing from 1 to N in steps of
542* 1 or 2
543*
544 k = 1
545 40 CONTINUE
546*
547* If K > N, exit from loop
548*
549 IF( k.GT.n )
550 $ GO TO 70
551 kstep = 1
552 p = k
553*
554* Determine rows and columns to be interchanged and whether
555* a 1-by-1 or 2-by-2 pivot block will be used
556*
557 absakk = cabs1( a( k, k ) )
558*
559* IMAX is the row-index of the largest off-diagonal element in
560* column K, and COLMAX is its absolute value.
561* Determine both COLMAX and IMAX.
562*
563 IF( k.LT.n ) THEN
564 imax = k + icamax( n-k, a( k+1, k ), 1 )
565 colmax = cabs1( a( imax, k ) )
566 ELSE
567 colmax = zero
568 END IF
569*
570 IF( ( max( absakk, colmax ).EQ.zero ) ) THEN
571*
572* Column K is zero or underflow: set INFO and continue
573*
574 IF( info.EQ.0 )
575 $ info = k
576 kp = k
577 ELSE
578*
579* Test for interchange
580*
581* Equivalent to testing for (used to handle NaN and Inf)
582* ABSAKK.GE.ALPHA*COLMAX
583*
584 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
585*
586* no interchange, use 1-by-1 pivot block
587*
588 kp = k
589 ELSE
590*
591 done = .false.
592*
593* Loop until pivot found
594*
595 42 CONTINUE
596*
597* Begin pivot search loop body
598*
599* JMAX is the column-index of the largest off-diagonal
600* element in row IMAX, and ROWMAX is its absolute value.
601* Determine both ROWMAX and JMAX.
602*
603 IF( imax.NE.k ) THEN
604 jmax = k - 1 + icamax( imax-k, a( imax, k ), lda )
605 rowmax = cabs1( a( imax, jmax ) )
606 ELSE
607 rowmax = zero
608 END IF
609*
610 IF( imax.LT.n ) THEN
611 itemp = imax + icamax( n-imax, a( imax+1, imax ),
612 $ 1 )
613 stemp = cabs1( a( itemp, imax ) )
614 IF( stemp.GT.rowmax ) THEN
615 rowmax = stemp
616 jmax = itemp
617 END IF
618 END IF
619*
620* Equivalent to testing for (used to handle NaN and Inf)
621* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
622*
623 IF( .NOT.( cabs1(a( imax, imax )).LT.alpha*rowmax ) )
624 $ THEN
625*
626* interchange rows and columns K and IMAX,
627* use 1-by-1 pivot block
628*
629 kp = imax
630 done = .true.
631*
632* Equivalent to testing for ROWMAX .EQ. COLMAX,
633* used to handle NaN and Inf
634*
635 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) ) THEN
636*
637* interchange rows and columns K+1 and IMAX,
638* use 2-by-2 pivot block
639*
640 kp = imax
641 kstep = 2
642 done = .true.
643 ELSE
644*
645* Pivot NOT found, set variables and repeat
646*
647 p = imax
648 colmax = rowmax
649 imax = jmax
650 END IF
651*
652* End pivot search loop body
653*
654 IF( .NOT. done ) GOTO 42
655*
656 END IF
657*
658* Swap TWO rows and TWO columns
659*
660* First swap
661*
662 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
663*
664* Interchange rows and column K and P in the trailing
665* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
666*
667 IF( p.LT.n )
668 $ CALL cswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
669 IF( p.GT.(k+1) )
670 $ CALL cswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda )
671 t = a( k, k )
672 a( k, k ) = a( p, p )
673 a( p, p ) = t
674 END IF
675*
676* Second swap
677*
678 kk = k + kstep - 1
679 IF( kp.NE.kk ) THEN
680*
681* Interchange rows and columns KK and KP in the trailing
682* submatrix A(k:n,k:n)
683*
684 IF( kp.LT.n )
685 $ CALL cswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
686 IF( ( kk.LT.n ) .AND. ( kp.GT.(kk+1) ) )
687 $ CALL cswap( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
688 $ lda )
689 t = a( kk, kk )
690 a( kk, kk ) = a( kp, kp )
691 a( kp, kp ) = t
692 IF( kstep.EQ.2 ) THEN
693 t = a( k+1, k )
694 a( k+1, k ) = a( kp, k )
695 a( kp, k ) = t
696 END IF
697 END IF
698*
699* Update the trailing submatrix
700*
701 IF( kstep.EQ.1 ) THEN
702*
703* 1-by-1 pivot block D(k): column k now holds
704*
705* W(k) = L(k)*D(k)
706*
707* where L(k) is the k-th column of L
708*
709 IF( k.LT.n ) THEN
710*
711* Perform a rank-1 update of A(k+1:n,k+1:n) and
712* store L(k) in column k
713*
714 IF( cabs1( a( k, k ) ).GE.sfmin ) THEN
715*
716* Perform a rank-1 update of A(k+1:n,k+1:n) as
717* A := A - L(k)*D(k)*L(k)**T
718* = A - W(k)*(1/D(k))*W(k)**T
719*
720 d11 = cone / a( k, k )
721 CALL csyr( uplo, n-k, -d11, a( k+1, k ), 1,
722 $ a( k+1, k+1 ), lda )
723*
724* Store L(k) in column k
725*
726 CALL cscal( n-k, d11, a( k+1, k ), 1 )
727 ELSE
728*
729* Store L(k) in column k
730*
731 d11 = a( k, k )
732 DO 46 ii = k + 1, n
733 a( ii, k ) = a( ii, k ) / d11
734 46 CONTINUE
735*
736* Perform a rank-1 update of A(k+1:n,k+1:n) as
737* A := A - L(k)*D(k)*L(k)**T
738* = A - W(k)*(1/D(k))*W(k)**T
739* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
740*
741 CALL csyr( uplo, n-k, -d11, a( k+1, k ), 1,
742 $ a( k+1, k+1 ), lda )
743 END IF
744 END IF
745*
746 ELSE
747*
748* 2-by-2 pivot block D(k): columns k and k+1 now hold
749*
750* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
751*
752* where L(k) and L(k+1) are the k-th and (k+1)-th columns
753* of L
754*
755*
756* Perform a rank-2 update of A(k+2:n,k+2:n) as
757*
758* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
759* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
760*
761* and store L(k) and L(k+1) in columns k and k+1
762*
763 IF( k.LT.n-1 ) THEN
764*
765 d21 = a( k+1, k )
766 d11 = a( k+1, k+1 ) / d21
767 d22 = a( k, k ) / d21
768 t = cone / ( d11*d22-cone )
769*
770 DO 60 j = k + 2, n
771*
772* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
773*
774 wk = t*( d11*a( j, k )-a( j, k+1 ) )
775 wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
776*
777* Perform a rank-2 update of A(k+2:n,k+2:n)
778*
779 DO 50 i = j, n
780 a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -
781 $ ( a( i, k+1 ) / d21 )*wkp1
782 50 CONTINUE
783*
784* Store L(k) and L(k+1) in cols k and k+1 for row J
785*
786 a( j, k ) = wk / d21
787 a( j, k+1 ) = wkp1 / d21
788*
789 60 CONTINUE
790*
791 END IF
792*
793 END IF
794 END IF
795*
796* Store details of the interchanges in IPIV
797*
798 IF( kstep.EQ.1 ) THEN
799 ipiv( k ) = kp
800 ELSE
801 ipiv( k ) = -p
802 ipiv( k+1 ) = -kp
803 END IF
804*
805* Increase K and return to the start of the main loop
806*
807 k = k + kstep
808 GO TO 40
809*
810 END IF
811*
812 70 CONTINUE
813*
814 RETURN
815*
816* End of CSYTF2_ROOK
817*

◆ csytrf()

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

CSYTRF

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

Purpose:
!>
!> CSYTRF computes the factorization of a complex symmetric matrix A
!> using the Bunch-Kaufman diagonal pivoting method.  The form of the
!> factorization is
!>
!>    A = U*D*U**T  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, 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
!>          = '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 COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L (see below for further details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>          interchanged and D(k,k) is a 1-by-1 diagonal block.
!>          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!>          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!>          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!>          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!>          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK >=1.  For best performance
!>          LWORK >= N*NB, where NB is the block size returned by ILAENV.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[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) is exactly zero.  The factorization
!>                has been completed, but the block diagonal matrix D is
!>                exactly singular, and division by zero will occur if it
!>                is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', then A = U*D*U**T, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>

Definition at line 181 of file csytrf.f.

182*
183* -- LAPACK computational routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 CHARACTER UPLO
189 INTEGER INFO, LDA, LWORK, N
190* ..
191* .. Array Arguments ..
192 INTEGER IPIV( * )
193 COMPLEX A( LDA, * ), WORK( * )
194* ..
195*
196* =====================================================================
197*
198* .. Local Scalars ..
199 LOGICAL LQUERY, UPPER
200 INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 INTEGER ILAENV
205 EXTERNAL lsame, ilaenv
206* ..
207* .. External Subroutines ..
208 EXTERNAL clasyf, csytf2, xerbla
209* ..
210* .. Intrinsic Functions ..
211 INTRINSIC max
212* ..
213* .. Executable Statements ..
214*
215* Test the input parameters.
216*
217 info = 0
218 upper = lsame( uplo, 'U' )
219 lquery = ( lwork.EQ.-1 )
220 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
221 info = -1
222 ELSE IF( n.LT.0 ) THEN
223 info = -2
224 ELSE IF( lda.LT.max( 1, n ) ) THEN
225 info = -4
226 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
227 info = -7
228 END IF
229*
230 IF( info.EQ.0 ) THEN
231*
232* Determine the block size
233*
234 nb = ilaenv( 1, 'CSYTRF', uplo, n, -1, -1, -1 )
235 lwkopt = n*nb
236 work( 1 ) = lwkopt
237 END IF
238*
239 IF( info.NE.0 ) THEN
240 CALL xerbla( 'CSYTRF', -info )
241 RETURN
242 ELSE IF( lquery ) THEN
243 RETURN
244 END IF
245*
246 nbmin = 2
247 ldwork = n
248 IF( nb.GT.1 .AND. nb.LT.n ) THEN
249 iws = ldwork*nb
250 IF( lwork.LT.iws ) THEN
251 nb = max( lwork / ldwork, 1 )
252 nbmin = max( 2, ilaenv( 2, 'CSYTRF', uplo, n, -1, -1, -1 ) )
253 END IF
254 ELSE
255 iws = 1
256 END IF
257 IF( nb.LT.nbmin )
258 $ nb = n
259*
260 IF( upper ) THEN
261*
262* Factorize A as U*D*U**T using the upper triangle of A
263*
264* K is the main loop index, decreasing from N to 1 in steps of
265* KB, where KB is the number of columns factorized by CLASYF;
266* KB is either NB or NB-1, or K for the last block
267*
268 k = n
269 10 CONTINUE
270*
271* If K < 1, exit from loop
272*
273 IF( k.LT.1 )
274 $ GO TO 40
275*
276 IF( k.GT.nb ) THEN
277*
278* Factorize columns k-kb+1:k of A and use blocked code to
279* update columns 1:k-kb
280*
281 CALL clasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
282 ELSE
283*
284* Use unblocked code to factorize columns 1:k of A
285*
286 CALL csytf2( uplo, k, a, lda, ipiv, iinfo )
287 kb = k
288 END IF
289*
290* Set INFO on the first occurrence of a zero pivot
291*
292 IF( info.EQ.0 .AND. iinfo.GT.0 )
293 $ info = iinfo
294*
295* Decrease K and return to the start of the main loop
296*
297 k = k - kb
298 GO TO 10
299*
300 ELSE
301*
302* Factorize A as L*D*L**T using the lower triangle of A
303*
304* K is the main loop index, increasing from 1 to N in steps of
305* KB, where KB is the number of columns factorized by CLASYF;
306* KB is either NB or NB-1, or N-K+1 for the last block
307*
308 k = 1
309 20 CONTINUE
310*
311* If K > N, exit from loop
312*
313 IF( k.GT.n )
314 $ GO TO 40
315*
316 IF( k.LE.n-nb ) THEN
317*
318* Factorize columns k:k+kb-1 of A and use blocked code to
319* update columns k+kb:n
320*
321 CALL clasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),
322 $ work, n, iinfo )
323 ELSE
324*
325* Use unblocked code to factorize columns k:n of A
326*
327 CALL csytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
328 kb = n - k + 1
329 END IF
330*
331* Set INFO on the first occurrence of a zero pivot
332*
333 IF( info.EQ.0 .AND. iinfo.GT.0 )
334 $ info = iinfo + k - 1
335*
336* Adjust IPIV
337*
338 DO 30 j = k, k + kb - 1
339 IF( ipiv( j ).GT.0 ) THEN
340 ipiv( j ) = ipiv( j ) + k - 1
341 ELSE
342 ipiv( j ) = ipiv( j ) - k + 1
343 END IF
344 30 CONTINUE
345*
346* Increase K and return to the start of the main loop
347*
348 k = k + kb
349 GO TO 20
350*
351 END IF
352*
353 40 CONTINUE
354 work( 1 ) = lwkopt
355 RETURN
356*
357* End of CSYTRF
358*
clasyf
subroutine clasyf(uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagona...
Definition clasyf.f:177
csytf2
subroutine csytf2(uplo, n, a, lda, ipiv, info)
CSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting ...
Definition csytf2.f:191

◆ csytrf_aa()

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

CSYTRF_AA

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

Purpose:
!>
!> CSYTRF_AA computes the factorization of a complex symmetric matrix A
!> using the Aasen's algorithm.  The form of the factorization is
!>
!>    A = U**T*T*U  or  A = L*T*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is a complex symmetric tridiagonal matrix.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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 COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the tridiagonal matrix is stored in the diagonals
!>          and the subdiagonals of A just below (or above) the diagonals,
!>          and L is stored below (or above) the subdiaonals, when UPLO
!>          is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK. LWORK >= MAX(1,2*N). For optimum performance
!>          LWORK >= N*(1+NB), where NB is the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file csytrf_aa.f.

132*
133* -- LAPACK computational routine --
134* -- LAPACK is a software package provided by Univ. of Tennessee, --
135* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136*
137 IMPLICIT NONE
138*
139* .. Scalar Arguments ..
140 CHARACTER UPLO
141 INTEGER N, LDA, LWORK, INFO
142* ..
143* .. Array Arguments ..
144 INTEGER IPIV( * )
145 COMPLEX A( LDA, * ), WORK( * )
146* ..
147*
148* =====================================================================
149* .. Parameters ..
150 COMPLEX ZERO, ONE
151 parameter( zero = 0.0e+0, one = 1.0e+0 )
152*
153* .. Local Scalars ..
154 LOGICAL LQUERY, UPPER
155 INTEGER J, LWKOPT
156 INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB
157 COMPLEX ALPHA
158* ..
159* .. External Functions ..
160 LOGICAL LSAME
161 INTEGER ILAENV
162 EXTERNAL lsame, ilaenv
163* ..
164* .. External Subroutines ..
165 EXTERNAL clasyf_aa, cgemm, cgemv, cscal, cswap, ccopy,
166 $ xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max
170* ..
171* .. Executable Statements ..
172*
173* Determine the block size
174*
175 nb = ilaenv( 1, 'CSYTRF_AA', uplo, n, -1, -1, -1 )
176*
177* Test the input parameters.
178*
179 info = 0
180 upper = lsame( uplo, 'U' )
181 lquery = ( lwork.EQ.-1 )
182 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
183 info = -1
184 ELSE IF( n.LT.0 ) THEN
185 info = -2
186 ELSE IF( lda.LT.max( 1, n ) ) THEN
187 info = -4
188 ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN
189 info = -7
190 END IF
191*
192 IF( info.EQ.0 ) THEN
193 lwkopt = (nb+1)*n
194 work( 1 ) = lwkopt
195 END IF
196*
197 IF( info.NE.0 ) THEN
198 CALL xerbla( 'CSYTRF_AA', -info )
199 RETURN
200 ELSE IF( lquery ) THEN
201 RETURN
202 END IF
203*
204* Quick return
205*
206 IF ( n.EQ.0 ) THEN
207 RETURN
208 ENDIF
209 ipiv( 1 ) = 1
210 IF ( n.EQ.1 ) THEN
211 RETURN
212 END IF
213*
214* Adjust block size based on the workspace size
215*
216 IF( lwork.LT.((1+nb)*n) ) THEN
217 nb = ( lwork-n ) / n
218 END IF
219*
220 IF( upper ) THEN
221*
222* .....................................................
223* Factorize A as U**T*D*U using the upper triangle of A
224* .....................................................
225*
226* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N))
227*
228 CALL ccopy( n, a( 1, 1 ), lda, work( 1 ), 1 )
229*
230* J is the main loop index, increasing from 1 to N in steps of
231* JB, where JB is the number of columns factorized by CLASYF;
232* JB is either NB, or N-J+1 for the last block
233*
234 j = 0
235 10 CONTINUE
236 IF( j.GE.n )
237 $ GO TO 20
238*
239* each step of the main loop
240* J is the last column of the previous panel
241* J1 is the first column of the current panel
242* K1 identifies if the previous column of the panel has been
243* explicitly stored, e.g., K1=1 for the first panel, and
244* K1=0 for the rest
245*
246 j1 = j + 1
247 jb = min( n-j1+1, nb )
248 k1 = max(1, j)-j
249*
250* Panel factorization
251*
252 CALL clasyf_aa( uplo, 2-k1, n-j, jb,
253 $ a( max(1, j), j+1 ), lda,
254 $ ipiv( j+1 ), work, n, work( n*nb+1 ) )
255*
256* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot)
257*
258 DO j2 = j+2, min(n, j+jb+1)
259 ipiv( j2 ) = ipiv( j2 ) + j
260 IF( (j2.NE.ipiv(j2)) .AND. ((j1-k1).GT.2) ) THEN
261 CALL cswap( j1-k1-2, a( 1, j2 ), 1,
262 $ a( 1, ipiv(j2) ), 1 )
263 END IF
264 END DO
265 j = j + jb
266*
267* Trailing submatrix update, where
268* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
269* WORK stores the current block of the auxiriarly matrix H
270*
271 IF( j.LT.n ) THEN
272*
273* If first panel and JB=1 (NB=1), then nothing to do
274*
275 IF( j1.GT.1 .OR. jb.GT.1 ) THEN
276*
277* Merge rank-1 update with BLAS-3 update
278*
279 alpha = a( j, j+1 )
280 a( j, j+1 ) = one
281 CALL ccopy( n-j, a( j-1, j+1 ), lda,
282 $ work( (j+1-j1+1)+jb*n ), 1 )
283 CALL cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
284*
285* K1 identifies if the previous column of the panel has been
286* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
287* while K1=0 and K2=1 for the rest
288*
289 IF( j1.GT.1 ) THEN
290*
291* Not first panel
292*
293 k2 = 1
294 ELSE
295*
296* First panel
297*
298 k2 = 0
299*
300* First update skips the first column
301*
302 jb = jb - 1
303 END IF
304*
305 DO j2 = j+1, n, nb
306 nj = min( nb, n-j2+1 )
307*
308* Update (J2, J2) diagonal block with CGEMV
309*
310 j3 = j2
311 DO mj = nj-1, 1, -1
312 CALL cgemv( 'No transpose', mj, jb+1,
313 $ -one, work( j3-j1+1+k1*n ), n,
314 $ a( j1-k2, j3 ), 1,
315 $ one, a( j3, j3 ), lda )
316 j3 = j3 + 1
317 END DO
318*
319* Update off-diagonal block of J2-th block row with CGEMM
320*
321 CALL cgemm( 'Transpose', 'Transpose',
322 $ nj, n-j3+1, jb+1,
323 $ -one, a( j1-k2, j2 ), lda,
324 $ work( j3-j1+1+k1*n ), n,
325 $ one, a( j2, j3 ), lda )
326 END DO
327*
328* Recover T( J, J+1 )
329*
330 a( j, j+1 ) = alpha
331 END IF
332*
333* WORK(J+1, 1) stores H(J+1, 1)
334*
335 CALL ccopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 )
336 END IF
337 GO TO 10
338 ELSE
339*
340* .....................................................
341* Factorize A as L*D*L**T using the lower triangle of A
342* .....................................................
343*
344* copy first column A(1:N, 1) into H(1:N, 1)
345* (stored in WORK(1:N))
346*
347 CALL ccopy( n, a( 1, 1 ), 1, work( 1 ), 1 )
348*
349* J is the main loop index, increasing from 1 to N in steps of
350* JB, where JB is the number of columns factorized by CLASYF;
351* JB is either NB, or N-J+1 for the last block
352*
353 j = 0
354 11 CONTINUE
355 IF( j.GE.n )
356 $ GO TO 20
357*
358* each step of the main loop
359* J is the last column of the previous panel
360* J1 is the first column of the current panel
361* K1 identifies if the previous column of the panel has been
362* explicitly stored, e.g., K1=1 for the first panel, and
363* K1=0 for the rest
364*
365 j1 = j+1
366 jb = min( n-j1+1, nb )
367 k1 = max(1, j)-j
368*
369* Panel factorization
370*
371 CALL clasyf_aa( uplo, 2-k1, n-j, jb,
372 $ a( j+1, max(1, j) ), lda,
373 $ ipiv( j+1 ), work, n, work( n*nb+1 ) )
374*
375* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot)
376*
377 DO j2 = j+2, min(n, j+jb+1)
378 ipiv( j2 ) = ipiv( j2 ) + j
379 IF( (j2.NE.ipiv(j2)) .AND. ((j1-k1).GT.2) ) THEN
380 CALL cswap( j1-k1-2, a( j2, 1 ), lda,
381 $ a( ipiv(j2), 1 ), lda )
382 END IF
383 END DO
384 j = j + jb
385*
386* Trailing submatrix update, where
387* A(J2+1, J1-1) stores L(J2+1, J1) and
388* WORK(J2+1, 1) stores H(J2+1, 1)
389*
390 IF( j.LT.n ) THEN
391*
392* if first panel and JB=1 (NB=1), then nothing to do
393*
394 IF( j1.GT.1 .OR. jb.GT.1 ) THEN
395*
396* Merge rank-1 update with BLAS-3 update
397*
398 alpha = a( j+1, j )
399 a( j+1, j ) = one
400 CALL ccopy( n-j, a( j+1, j-1 ), 1,
401 $ work( (j+1-j1+1)+jb*n ), 1 )
402 CALL cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
403*
404* K1 identifies if the previous column of the panel has been
405* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
406* while K1=0 and K2=1 for the rest
407*
408 IF( j1.GT.1 ) THEN
409*
410* Not first panel
411*
412 k2 = 1
413 ELSE
414*
415* First panel
416*
417 k2 = 0
418*
419* First update skips the first column
420*
421 jb = jb - 1
422 END IF
423*
424 DO j2 = j+1, n, nb
425 nj = min( nb, n-j2+1 )
426*
427* Update (J2, J2) diagonal block with CGEMV
428*
429 j3 = j2
430 DO mj = nj-1, 1, -1
431 CALL cgemv( 'No transpose', mj, jb+1,
432 $ -one, work( j3-j1+1+k1*n ), n,
433 $ a( j3, j1-k2 ), lda,
434 $ one, a( j3, j3 ), 1 )
435 j3 = j3 + 1
436 END DO
437*
438* Update off-diagonal block in J2-th block column with CGEMM
439*
440 CALL cgemm( 'No transpose', 'Transpose',
441 $ n-j3+1, nj, jb+1,
442 $ -one, work( j3-j1+1+k1*n ), n,
443 $ a( j2, j1-k2 ), lda,
444 $ one, a( j3, j2 ), lda )
445 END DO
446*
447* Recover T( J+1, J )
448*
449 a( j+1, j ) = alpha
450 END IF
451*
452* WORK(J+1, 1) stores H(J+1, 1)
453*
454 CALL ccopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 )
455 END IF
456 GO TO 11
457 END IF
458*
459 20 CONTINUE
460 work( 1 ) = lwkopt
461 RETURN
462*
463* End of CSYTRF_AA
464*
clasyf_aa
subroutine clasyf_aa(uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
CLASYF_AA
Definition clasyf_aa.f:144

◆ csytrf_aa_2stage()

subroutine csytrf_aa_2stage ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex, dimension( * ) work,
integer lwork,
integer info )

CSYTRF_AA_2STAGE

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

Purpose:
!>
!> CSYTRF_AA_2STAGE computes the factorization of a complex symmetric matrix A
!> using the Aasen's algorithm.  The form of the factorization is
!>
!>    A = U**T*T*U  or  A = L*T*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is a complex symmetric band matrix with the
!> bandwidth of NB (NB is internally selected and stored in TB( 1 ), and T is 
!> LU factorized with partial pivoting).
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = '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 COMPLEX array, dimension (LDA,N)
!>          On entry, the hermitian matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, L is stored below (or above) the subdiaonal blocks,
!>          when UPLO  is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX array, dimension (LTB)
!>          On exit, details of the LU factorization of the band matrix.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N, internally
!>          used to select NB such that LTB >= (3*NB+1)*N.
!>
!>          If LTB = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of LTB, 
!>          returns this value as the first entry of TB, and
!>          no error message related to LTB is issued by XERBLA.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of T were interchanged with the
!>          row and column IPIV(k).
!>
[out]WORK
!>          WORK is COMPLEX workspace of size LWORK
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The size of WORK. LWORK >= N, internally used to select NB
!>          such that LWORK >= N*NB.
!>
!>          If LWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the WORK array,
!>          returns this value as the first entry of the WORK array, and
!>          no error message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, band LU factorization failed on i-th column
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 158 of file csytrf_aa_2stage.f.

160*
161* -- LAPACK computational routine --
162* -- LAPACK is a software package provided by Univ. of Tennessee, --
163* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
164*
165 IMPLICIT NONE
166*
167* .. Scalar Arguments ..
168 CHARACTER UPLO
169 INTEGER N, LDA, LTB, LWORK, INFO
170* ..
171* .. Array Arguments ..
172 INTEGER IPIV( * ), IPIV2( * )
173 COMPLEX A( LDA, * ), TB( * ), WORK( * )
174* ..
175*
176* =====================================================================
177* .. Parameters ..
178 COMPLEX CZERO, CONE
179 parameter( czero = ( 0.0e+0, 0.0e+0 ),
180 $ cone = ( 1.0e+0, 0.0e+0 ) )
181*
182* .. Local Scalars ..
183 LOGICAL UPPER, TQUERY, WQUERY
184 INTEGER I, J, K, I1, I2, TD
185 INTEGER LDTB, NB, KB, JB, NT, IINFO
186 COMPLEX PIV
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 INTEGER ILAENV
191 EXTERNAL lsame, ilaenv
192* ..
193* .. External Subroutines ..
194 EXTERNAL ccopy, cgbtrf, cgemm, cgetrf, clacpy,
195 $ claset, ctrsm, cswap, xerbla
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC min, max
199* ..
200* .. Executable Statements ..
201*
202* Test the input parameters.
203*
204 info = 0
205 upper = lsame( uplo, 'U' )
206 wquery = ( lwork.EQ.-1 )
207 tquery = ( ltb.EQ.-1 )
208 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
209 info = -1
210 ELSE IF( n.LT.0 ) THEN
211 info = -2
212 ELSE IF( lda.LT.max( 1, n ) ) THEN
213 info = -4
214 ELSE IF ( ltb .LT. 4*n .AND. .NOT.tquery ) THEN
215 info = -6
216 ELSE IF ( lwork .LT. n .AND. .NOT.wquery ) THEN
217 info = -10
218 END IF
219*
220 IF( info.NE.0 ) THEN
221 CALL xerbla( 'CSYTRF_AA_2STAGE', -info )
222 RETURN
223 END IF
224*
225* Answer the query
226*
227 nb = ilaenv( 1, 'CSYTRF_AA_2STAGE', uplo, n, -1, -1, -1 )
228 IF( info.EQ.0 ) THEN
229 IF( tquery ) THEN
230 tb( 1 ) = (3*nb+1)*n
231 END IF
232 IF( wquery ) THEN
233 work( 1 ) = n*nb
234 END IF
235 END IF
236 IF( tquery .OR. wquery ) THEN
237 RETURN
238 END IF
239*
240* Quick return
241*
242 IF ( n.EQ.0 ) THEN
243 RETURN
244 ENDIF
245*
246* Determine the number of the block size
247*
248 ldtb = ltb/n
249 IF( ldtb .LT. 3*nb+1 ) THEN
250 nb = (ldtb-1)/3
251 END IF
252 IF( lwork .LT. nb*n ) THEN
253 nb = lwork/n
254 END IF
255*
256* Determine the number of the block columns
257*
258 nt = (n+nb-1)/nb
259 td = 2*nb
260 kb = min(nb, n)
261*
262* Initialize vectors/matrices
263*
264 DO j = 1, kb
265 ipiv( j ) = j
266 END DO
267*
268* Save NB
269*
270 tb( 1 ) = nb
271*
272 IF( upper ) THEN
273*
274* .....................................................
275* Factorize A as U**T*D*U using the upper triangle of A
276* .....................................................
277*
278 DO j = 0, nt-1
279*
280* Generate Jth column of W and H
281*
282 kb = min(nb, n-j*nb)
283 DO i = 1, j-1
284 IF( i.EQ.1 ) THEN
285* H(I,J) = T(I,I)*U(I,J) + T(I+1,I)*U(I+1,J)
286 IF( i .EQ. (j-1) ) THEN
287 jb = nb+kb
288 ELSE
289 jb = 2*nb
290 END IF
291 CALL cgemm( 'NoTranspose', 'NoTranspose',
292 $ nb, kb, jb,
293 $ cone, tb( td+1 + (i*nb)*ldtb ), ldtb-1,
294 $ a( (i-1)*nb+1, j*nb+1 ), lda,
295 $ czero, work( i*nb+1 ), n )
296 ELSE
297* H(I,J) = T(I,I-1)*U(I-1,J) + T(I,I)*U(I,J) + T(I,I+1)*U(I+1,J)
298 IF( i .EQ. j-1) THEN
299 jb = 2*nb+kb
300 ELSE
301 jb = 3*nb
302 END IF
303 CALL cgemm( 'NoTranspose', 'NoTranspose',
304 $ nb, kb, jb,
305 $ cone, tb( td+nb+1 + ((i-1)*nb)*ldtb ),
306 $ ldtb-1,
307 $ a( (i-2)*nb+1, j*nb+1 ), lda,
308 $ czero, work( i*nb+1 ), n )
309 END IF
310 END DO
311*
312* Compute T(J,J)
313*
314 CALL clacpy( 'Upper', kb, kb, a( j*nb+1, j*nb+1 ), lda,
315 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
316 IF( j.GT.1 ) THEN
317* T(J,J) = U(1:J,J)'*H(1:J)
318 CALL cgemm( 'Transpose', 'NoTranspose',
319 $ kb, kb, (j-1)*nb,
320 $ -cone, a( 1, j*nb+1 ), lda,
321 $ work( nb+1 ), n,
322 $ cone, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
323* T(J,J) += U(J,J)'*T(J,J-1)*U(J-1,J)
324 CALL cgemm( 'Transpose', 'NoTranspose',
325 $ kb, nb, kb,
326 $ cone, a( (j-1)*nb+1, j*nb+1 ), lda,
327 $ tb( td+nb+1 + ((j-1)*nb)*ldtb ), ldtb-1,
328 $ czero, work( 1 ), n )
329 CALL cgemm( 'NoTranspose', 'NoTranspose',
330 $ kb, kb, nb,
331 $ -cone, work( 1 ), n,
332 $ a( (j-2)*nb+1, j*nb+1 ), lda,
333 $ cone, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
334 END IF
335*
336* Expand T(J,J) into full format
337*
338 DO i = 1, kb
339 DO k = i+1, kb
340 tb( td+(k-i)+1 + (j*nb+i-1)*ldtb )
341 $ = tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb )
342 END DO
343 END DO
344 IF( j.GT.0 ) THEN
345c CALL CHEGST( 1, 'Upper', KB,
346c $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1,
347c $ A( (J-1)*NB+1, J*NB+1 ), LDA, IINFO )
348 CALL ctrsm( 'L', 'U', 'T', 'N', kb, kb, cone,
349 $ a( (j-1)*nb+1, j*nb+1 ), lda,
350 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
351 CALL ctrsm( 'R', 'U', 'N', 'N', kb, kb, cone,
352 $ a( (j-1)*nb+1, j*nb+1 ), lda,
353 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
354 END IF
355*
356 IF( j.LT.nt-1 ) THEN
357 IF( j.GT.0 ) THEN
358*
359* Compute H(J,J)
360*
361 IF( j.EQ.1 ) THEN
362 CALL cgemm( 'NoTranspose', 'NoTranspose',
363 $ kb, kb, kb,
364 $ cone, tb( td+1 + (j*nb)*ldtb ), ldtb-1,
365 $ a( (j-1)*nb+1, j*nb+1 ), lda,
366 $ czero, work( j*nb+1 ), n )
367 ELSE
368 CALL cgemm( 'NoTranspose', 'NoTranspose',
369 $ kb, kb, nb+kb,
370 $ cone, tb( td+nb+1 + ((j-1)*nb)*ldtb ),
371 $ ldtb-1,
372 $ a( (j-2)*nb+1, j*nb+1 ), lda,
373 $ czero, work( j*nb+1 ), n )
374 END IF
375*
376* Update with the previous column
377*
378 CALL cgemm( 'Transpose', 'NoTranspose',
379 $ nb, n-(j+1)*nb, j*nb,
380 $ -cone, work( nb+1 ), n,
381 $ a( 1, (j+1)*nb+1 ), lda,
382 $ cone, a( j*nb+1, (j+1)*nb+1 ), lda )
383 END IF
384*
385* Copy panel to workspace to call CGETRF
386*
387 DO k = 1, nb
388 CALL ccopy( n-(j+1)*nb,
389 $ a( j*nb+k, (j+1)*nb+1 ), lda,
390 $ work( 1+(k-1)*n ), 1 )
391 END DO
392*
393* Factorize panel
394*
395 CALL cgetrf( n-(j+1)*nb, nb,
396 $ work, n,
397 $ ipiv( (j+1)*nb+1 ), iinfo )
398c IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN
399c INFO = IINFO+(J+1)*NB
400c END IF
401*
402* Copy panel back
403*
404 DO k = 1, nb
405 CALL ccopy( n-(j+1)*nb,
406 $ work( 1+(k-1)*n ), 1,
407 $ a( j*nb+k, (j+1)*nb+1 ), lda )
408 END DO
409*
410* Compute T(J+1, J), zero out for GEMM update
411*
412 kb = min(nb, n-(j+1)*nb)
413 CALL claset( 'Full', kb, nb, czero, czero,
414 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
415 CALL clacpy( 'Upper', kb, nb,
416 $ work, n,
417 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
418 IF( j.GT.0 ) THEN
419 CALL ctrsm( 'R', 'U', 'N', 'U', kb, nb, cone,
420 $ a( (j-1)*nb+1, j*nb+1 ), lda,
421 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
422 END IF
423*
424* Copy T(J,J+1) into T(J+1, J), both upper/lower for GEMM
425* updates
426*
427 DO k = 1, nb
428 DO i = 1, kb
429 tb( td-nb+k-i+1 + (j*nb+nb+i-1)*ldtb )
430 $ = tb( td+nb+i-k+1 + (j*nb+k-1)*ldtb )
431 END DO
432 END DO
433 CALL claset( 'Lower', kb, nb, czero, cone,
434 $ a( j*nb+1, (j+1)*nb+1), lda )
435*
436* Apply pivots to trailing submatrix of A
437*
438 DO k = 1, kb
439* > Adjust ipiv
440 ipiv( (j+1)*nb+k ) = ipiv( (j+1)*nb+k ) + (j+1)*nb
441*
442 i1 = (j+1)*nb+k
443 i2 = ipiv( (j+1)*nb+k )
444 IF( i1.NE.i2 ) THEN
445* > Apply pivots to previous columns of L
446 CALL cswap( k-1, a( (j+1)*nb+1, i1 ), 1,
447 $ a( (j+1)*nb+1, i2 ), 1 )
448* > Swap A(I1+1:M, I1) with A(I2, I1+1:M)
449 IF( i2.GT.(i1+1) )
450 $ CALL cswap( i2-i1-1, a( i1, i1+1 ), lda,
451 $ a( i1+1, i2 ), 1 )
452* > Swap A(I2+1:M, I1) with A(I2+1:M, I2)
453 IF( i2.LT.n )
454 $ CALL cswap( n-i2, a( i1, i2+1 ), lda,
455 $ a( i2, i2+1 ), lda )
456* > Swap A(I1, I1) with A(I2, I2)
457 piv = a( i1, i1 )
458 a( i1, i1 ) = a( i2, i2 )
459 a( i2, i2 ) = piv
460* > Apply pivots to previous columns of L
461 IF( j.GT.0 ) THEN
462 CALL cswap( j*nb, a( 1, i1 ), 1,
463 $ a( 1, i2 ), 1 )
464 END IF
465 ENDIF
466 END DO
467 END IF
468 END DO
469 ELSE
470*
471* .....................................................
472* Factorize A as L*D*L**T using the lower triangle of A
473* .....................................................
474*
475 DO j = 0, nt-1
476*
477* Generate Jth column of W and H
478*
479 kb = min(nb, n-j*nb)
480 DO i = 1, j-1
481 IF( i.EQ.1 ) THEN
482* H(I,J) = T(I,I)*L(J,I)' + T(I+1,I)'*L(J,I+1)'
483 IF( i .EQ. (j-1) ) THEN
484 jb = nb+kb
485 ELSE
486 jb = 2*nb
487 END IF
488 CALL cgemm( 'NoTranspose', 'Transpose',
489 $ nb, kb, jb,
490 $ cone, tb( td+1 + (i*nb)*ldtb ), ldtb-1,
491 $ a( j*nb+1, (i-1)*nb+1 ), lda,
492 $ czero, work( i*nb+1 ), n )
493 ELSE
494* H(I,J) = T(I,I-1)*L(J,I-1)' + T(I,I)*L(J,I)' + T(I,I+1)*L(J,I+1)'
495 IF( i .EQ. (j-1) ) THEN
496 jb = 2*nb+kb
497 ELSE
498 jb = 3*nb
499 END IF
500 CALL cgemm( 'NoTranspose', 'Transpose',
501 $ nb, kb, jb,
502 $ cone, tb( td+nb+1 + ((i-1)*nb)*ldtb ),
503 $ ldtb-1,
504 $ a( j*nb+1, (i-2)*nb+1 ), lda,
505 $ czero, work( i*nb+1 ), n )
506 END IF
507 END DO
508*
509* Compute T(J,J)
510*
511 CALL clacpy( 'Lower', kb, kb, a( j*nb+1, j*nb+1 ), lda,
512 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
513 IF( j.GT.1 ) THEN
514* T(J,J) = L(J,1:J)*H(1:J)
515 CALL cgemm( 'NoTranspose', 'NoTranspose',
516 $ kb, kb, (j-1)*nb,
517 $ -cone, a( j*nb+1, 1 ), lda,
518 $ work( nb+1 ), n,
519 $ cone, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
520* T(J,J) += L(J,J)*T(J,J-1)*L(J,J-1)'
521 CALL cgemm( 'NoTranspose', 'NoTranspose',
522 $ kb, nb, kb,
523 $ cone, a( j*nb+1, (j-1)*nb+1 ), lda,
524 $ tb( td+nb+1 + ((j-1)*nb)*ldtb ), ldtb-1,
525 $ czero, work( 1 ), n )
526 CALL cgemm( 'NoTranspose', 'Transpose',
527 $ kb, kb, nb,
528 $ -cone, work( 1 ), n,
529 $ a( j*nb+1, (j-2)*nb+1 ), lda,
530 $ cone, tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
531 END IF
532*
533* Expand T(J,J) into full format
534*
535 DO i = 1, kb
536 DO k = i+1, kb
537 tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb )
538 $ = tb( td+(k-i)+1 + (j*nb+i-1)*ldtb )
539 END DO
540 END DO
541 IF( j.GT.0 ) THEN
542c CALL CHEGST( 1, 'Lower', KB,
543c $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1,
544c $ A( J*NB+1, (J-1)*NB+1 ), LDA, IINFO )
545 CALL ctrsm( 'L', 'L', 'N', 'N', kb, kb, cone,
546 $ a( j*nb+1, (j-1)*nb+1 ), lda,
547 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
548 CALL ctrsm( 'R', 'L', 'T', 'N', kb, kb, cone,
549 $ a( j*nb+1, (j-1)*nb+1 ), lda,
550 $ tb( td+1 + (j*nb)*ldtb ), ldtb-1 )
551 END IF
552*
553* Symmetrize T(J,J)
554*
555 DO i = 1, kb
556 DO k = i+1, kb
557 tb( td-(k-(i+1)) + (j*nb+k-1)*ldtb )
558 $ = tb( td+(k-i)+1 + (j*nb+i-1)*ldtb )
559 END DO
560 END DO
561*
562 IF( j.LT.nt-1 ) THEN
563 IF( j.GT.0 ) THEN
564*
565* Compute H(J,J)
566*
567 IF( j.EQ.1 ) THEN
568 CALL cgemm( 'NoTranspose', 'Transpose',
569 $ kb, kb, kb,
570 $ cone, tb( td+1 + (j*nb)*ldtb ), ldtb-1,
571 $ a( j*nb+1, (j-1)*nb+1 ), lda,
572 $ czero, work( j*nb+1 ), n )
573 ELSE
574 CALL cgemm( 'NoTranspose', 'Transpose',
575 $ kb, kb, nb+kb,
576 $ cone, tb( td+nb+1 + ((j-1)*nb)*ldtb ),
577 $ ldtb-1,
578 $ a( j*nb+1, (j-2)*nb+1 ), lda,
579 $ czero, work( j*nb+1 ), n )
580 END IF
581*
582* Update with the previous column
583*
584 CALL cgemm( 'NoTranspose', 'NoTranspose',
585 $ n-(j+1)*nb, nb, j*nb,
586 $ -cone, a( (j+1)*nb+1, 1 ), lda,
587 $ work( nb+1 ), n,
588 $ cone, a( (j+1)*nb+1, j*nb+1 ), lda )
589 END IF
590*
591* Factorize panel
592*
593 CALL cgetrf( n-(j+1)*nb, nb,
594 $ a( (j+1)*nb+1, j*nb+1 ), lda,
595 $ ipiv( (j+1)*nb+1 ), iinfo )
596c IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN
597c INFO = IINFO+(J+1)*NB
598c END IF
599*
600* Compute T(J+1, J), zero out for GEMM update
601*
602 kb = min(nb, n-(j+1)*nb)
603 CALL claset( 'Full', kb, nb, czero, czero,
604 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
605 CALL clacpy( 'Upper', kb, nb,
606 $ a( (j+1)*nb+1, j*nb+1 ), lda,
607 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
608 IF( j.GT.0 ) THEN
609 CALL ctrsm( 'R', 'L', 'T', 'U', kb, nb, cone,
610 $ a( j*nb+1, (j-1)*nb+1 ), lda,
611 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
612 END IF
613*
614* Copy T(J+1,J) into T(J, J+1), both upper/lower for GEMM
615* updates
616*
617 DO k = 1, nb
618 DO i = 1, kb
619 tb( td-nb+k-i+1 + (j*nb+nb+i-1)*ldtb ) =
620 $ tb( td+nb+i-k+1 + (j*nb+k-1)*ldtb )
621 END DO
622 END DO
623 CALL claset( 'Upper', kb, nb, czero, cone,
624 $ a( (j+1)*nb+1, j*nb+1 ), lda )
625*
626* Apply pivots to trailing submatrix of A
627*
628 DO k = 1, kb
629* > Adjust ipiv
630 ipiv( (j+1)*nb+k ) = ipiv( (j+1)*nb+k ) + (j+1)*nb
631*
632 i1 = (j+1)*nb+k
633 i2 = ipiv( (j+1)*nb+k )
634 IF( i1.NE.i2 ) THEN
635* > Apply pivots to previous columns of L
636 CALL cswap( k-1, a( i1, (j+1)*nb+1 ), lda,
637 $ a( i2, (j+1)*nb+1 ), lda )
638* > Swap A(I1+1:M, I1) with A(I2, I1+1:M)
639 IF( i2.GT.(i1+1) )
640 $ CALL cswap( i2-i1-1, a( i1+1, i1 ), 1,
641 $ a( i2, i1+1 ), lda )
642* > Swap A(I2+1:M, I1) with A(I2+1:M, I2)
643 IF( i2.LT.n )
644 $ CALL cswap( n-i2, a( i2+1, i1 ), 1,
645 $ a( i2+1, i2 ), 1 )
646* > Swap A(I1, I1) with A(I2, I2)
647 piv = a( i1, i1 )
648 a( i1, i1 ) = a( i2, i2 )
649 a( i2, i2 ) = piv
650* > Apply pivots to previous columns of L
651 IF( j.GT.0 ) THEN
652 CALL cswap( j*nb, a( i1, 1 ), lda,
653 $ a( i2, 1 ), lda )
654 END IF
655 ENDIF
656 END DO
657*
658* Apply pivots to previous columns of L
659*
660c CALL CLASWP( J*NB, A( 1, 1 ), LDA,
661c $ (J+1)*NB+1, (J+1)*NB+KB, IPIV, 1 )
662 END IF
663 END DO
664 END IF
665*
666* Factor the band matrix
667 CALL cgbtrf( n, n, nb, nb, tb, ldtb, ipiv2, info )
668*
669 RETURN
670*
671* End of CSYTRF_AA_2STAGE
672*

◆ csytrf_rk()

subroutine csytrf_rk ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( * ) work,
integer lwork,
integer info )

CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).

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

Purpose:
!> CSYTRF_RK computes the factorization of a complex symmetric matrix A
!> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!>
!>    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.
!> For more information see Further Details section.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.
!>            If UPLO = 'U': the leading N-by-N upper triangular part
!>            of A contains the upper triangular part of the matrix A,
!>            and the strictly lower triangular part of A is not
!>            referenced.
!>
!>            If UPLO = 'L': the leading N-by-N lower triangular part
!>            of A contains the lower triangular part of the matrix A,
!>            and the strictly upper triangular part of A is not
!>            referenced.
!>
!>          On exit, contains:
!>            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
!>                are stored on exit 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]E
!>          E is COMPLEX array, dimension (N)
!>          On exit, 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) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is set to 0 in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          IPIV describes the permutation matrix P in the factorization
!>          of matrix A as follows. The absolute value of IPIV(k)
!>          represents the index of row and column that were
!>          interchanged with the k-th row and column. The value of UPLO
!>          describes the order in which the interchanges were applied.
!>          Also, the sign of IPIV represents the block structure of
!>          the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
!>          diagonal blocks which correspond to 1 or 2 interchanges
!>          at each factorization step. For more info see Further
!>          Details section.
!>
!>          If UPLO = 'U',
!>          ( in factorization order, k decreases from N to 1 ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the matrix A(1:N,1:N);
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k-1) < 0 means:
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k-1) != k-1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k-1) = k-1, no interchange occurred.
!>
!>            c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
!>          If UPLO = 'L',
!>          ( in factorization order, k increases from 1 to N ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the matrix A(1:N,1:N).
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k+1) < 0 means:
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k+1) != k+1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k+1) = k+1, no interchange occurred.
!>
!>            c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension ( MAX(1,LWORK) ).
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK >=1.  For best performance
!>          LWORK >= N*NB, where NB is the block size returned
!>          by ILAENV.
!>
!>          If LWORK = -1, then a workspace query is assumed;
!>          the routine only calculates the optimal size of the WORK
!>          array, returns this value as the first entry of the WORK
!>          array, and no error message related to LWORK is issued
!>          by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>
!>          < 0: If INFO = -k, the k-th argument had an illegal value
!>
!>          > 0: If INFO = k, the matrix A is singular, because:
!>                 If UPLO = 'U': column k in the upper
!>                 triangular part of A contains all zeros.
!>                 If UPLO = 'L': column k in the lower
!>                 triangular part of A contains all zeros.
!>
!>               Therefore D(k,k) is exactly zero, and superdiagonal
!>               elements of column k of U (or subdiagonal elements of
!>               column k of L ) are all zeros. The factorization has
!>               been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if
!>               it is used to solve a system of equations.
!>
!>               NOTE: INFO only stores the first occurrence of
!>               a singularity, any subsequent occurrence of singularity
!>               is not stored in INFO even though the factorization
!>               always completes.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!> TODO: put correct description
!>
Contributors:
!>
!>  December 2016,  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 257 of file csytrf_rk.f.

259*
260* -- LAPACK computational routine --
261* -- LAPACK is a software package provided by Univ. of Tennessee, --
262* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
263*
264* .. Scalar Arguments ..
265 CHARACTER UPLO
266 INTEGER INFO, LDA, LWORK, N
267* ..
268* .. Array Arguments ..
269 INTEGER IPIV( * )
270 COMPLEX A( LDA, * ), E( * ), WORK( * )
271* ..
272*
273* =====================================================================
274*
275* .. Local Scalars ..
276 LOGICAL LQUERY, UPPER
277 INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
278 $ NB, NBMIN
279* ..
280* .. External Functions ..
281 LOGICAL LSAME
282 INTEGER ILAENV
283 EXTERNAL lsame, ilaenv
284* ..
285* .. External Subroutines ..
286 EXTERNAL clasyf_rk, csytf2_rk, cswap, xerbla
287* ..
288* .. Intrinsic Functions ..
289 INTRINSIC abs, max
290* ..
291* .. Executable Statements ..
292*
293* Test the input parameters.
294*
295 info = 0
296 upper = lsame( uplo, 'U' )
297 lquery = ( lwork.EQ.-1 )
298 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
299 info = -1
300 ELSE IF( n.LT.0 ) THEN
301 info = -2
302 ELSE IF( lda.LT.max( 1, n ) ) THEN
303 info = -4
304 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
305 info = -8
306 END IF
307*
308 IF( info.EQ.0 ) THEN
309*
310* Determine the block size
311*
312 nb = ilaenv( 1, 'CSYTRF_RK', uplo, n, -1, -1, -1 )
313 lwkopt = n*nb
314 work( 1 ) = lwkopt
315 END IF
316*
317 IF( info.NE.0 ) THEN
318 CALL xerbla( 'CSYTRF_RK', -info )
319 RETURN
320 ELSE IF( lquery ) THEN
321 RETURN
322 END IF
323*
324 nbmin = 2
325 ldwork = n
326 IF( nb.GT.1 .AND. nb.LT.n ) THEN
327 iws = ldwork*nb
328 IF( lwork.LT.iws ) THEN
329 nb = max( lwork / ldwork, 1 )
330 nbmin = max( 2, ilaenv( 2, 'CSYTRF_RK',
331 $ uplo, n, -1, -1, -1 ) )
332 END IF
333 ELSE
334 iws = 1
335 END IF
336 IF( nb.LT.nbmin )
337 $ nb = n
338*
339 IF( upper ) THEN
340*
341* Factorize A as U*D*U**T using the upper triangle of A
342*
343* K is the main loop index, decreasing from N to 1 in steps of
344* KB, where KB is the number of columns factorized by CLASYF_RK;
345* KB is either NB or NB-1, or K for the last block
346*
347 k = n
348 10 CONTINUE
349*
350* If K < 1, exit from loop
351*
352 IF( k.LT.1 )
353 $ GO TO 15
354*
355 IF( k.GT.nb ) THEN
356*
357* Factorize columns k-kb+1:k of A and use blocked code to
358* update columns 1:k-kb
359*
360 CALL clasyf_rk( uplo, k, nb, kb, a, lda, e,
361 $ ipiv, work, ldwork, iinfo )
362 ELSE
363*
364* Use unblocked code to factorize columns 1:k of A
365*
366 CALL csytf2_rk( uplo, k, a, lda, e, ipiv, iinfo )
367 kb = k
368 END IF
369*
370* Set INFO on the first occurrence of a zero pivot
371*
372 IF( info.EQ.0 .AND. iinfo.GT.0 )
373 $ info = iinfo
374*
375* No need to adjust IPIV
376*
377*
378* Apply permutations to the leading panel 1:k-1
379*
380* Read IPIV from the last block factored, i.e.
381* indices k-kb+1:k and apply row permutations to the
382* last k+1 colunms k+1:N after that block
383* (We can do the simple loop over IPIV with decrement -1,
384* since the ABS value of IPIV( I ) represents the row index
385* of the interchange with row i in both 1x1 and 2x2 pivot cases)
386*
387 IF( k.LT.n ) THEN
388 DO i = k, ( k - kb + 1 ), -1
389 ip = abs( ipiv( i ) )
390 IF( ip.NE.i ) THEN
391 CALL cswap( n-k, a( i, k+1 ), lda,
392 $ a( ip, k+1 ), lda )
393 END IF
394 END DO
395 END IF
396*
397* Decrease K and return to the start of the main loop
398*
399 k = k - kb
400 GO TO 10
401*
402* This label is the exit from main loop over K decreasing
403* from N to 1 in steps of KB
404*
405 15 CONTINUE
406*
407 ELSE
408*
409* Factorize A as L*D*L**T using the lower triangle of A
410*
411* K is the main loop index, increasing from 1 to N in steps of
412* KB, where KB is the number of columns factorized by CLASYF_RK;
413* KB is either NB or NB-1, or N-K+1 for the last block
414*
415 k = 1
416 20 CONTINUE
417*
418* If K > N, exit from loop
419*
420 IF( k.GT.n )
421 $ GO TO 35
422*
423 IF( k.LE.n-nb ) THEN
424*
425* Factorize columns k:k+kb-1 of A and use blocked code to
426* update columns k+kb:n
427*
428 CALL clasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),
429 $ ipiv( k ), work, ldwork, iinfo )
430
431
432 ELSE
433*
434* Use unblocked code to factorize columns k:n of A
435*
436 CALL csytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),
437 $ ipiv( k ), iinfo )
438 kb = n - k + 1
439*
440 END IF
441*
442* Set INFO on the first occurrence of a zero pivot
443*
444 IF( info.EQ.0 .AND. iinfo.GT.0 )
445 $ info = iinfo + k - 1
446*
447* Adjust IPIV
448*
449 DO i = k, k + kb - 1
450 IF( ipiv( i ).GT.0 ) THEN
451 ipiv( i ) = ipiv( i ) + k - 1
452 ELSE
453 ipiv( i ) = ipiv( i ) - k + 1
454 END IF
455 END DO
456*
457* Apply permutations to the leading panel 1:k-1
458*
459* Read IPIV from the last block factored, i.e.
460* indices k:k+kb-1 and apply row permutations to the
461* first k-1 colunms 1:k-1 before that block
462* (We can do the simple loop over IPIV with increment 1,
463* since the ABS value of IPIV( I ) represents the row index
464* of the interchange with row i in both 1x1 and 2x2 pivot cases)
465*
466 IF( k.GT.1 ) THEN
467 DO i = k, ( k + kb - 1 ), 1
468 ip = abs( ipiv( i ) )
469 IF( ip.NE.i ) THEN
470 CALL cswap( k-1, a( i, 1 ), lda,
471 $ a( ip, 1 ), lda )
472 END IF
473 END DO
474 END IF
475*
476* Increase K and return to the start of the main loop
477*
478 k = k + kb
479 GO TO 20
480*
481* This label is the exit from main loop over K increasing
482* from 1 to N in steps of KB
483*
484 35 CONTINUE
485*
486* End Lower
487*
488 END IF
489*
490 work( 1 ) = lwkopt
491 RETURN
492*
493* End of CSYTRF_RK
494*
csytf2_rk
subroutine csytf2_rk(uplo, n, a, lda, e, ipiv, info)
CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
Definition csytf2_rk.f:241
clasyf_rk
subroutine clasyf_rk(uplo, n, nb, kb, a, lda, e, ipiv, w, ldw, info)
CLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bun...
Definition clasyf_rk.f:262

◆ csytrf_rook()

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

CSYTRF_ROOK

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

Purpose:
!>
!> CSYTRF_ROOK computes the factorization of a complex symmetric matrix A
!> using the bounded Bunch-Kaufman () diagonal pivoting method.
!> The form of the factorization is
!>
!>    A = U*D*U**T  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, 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
!>          = '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 COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L (see below for further details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>
!>          If UPLO = 'U':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>               If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
!>               columns k and -IPIV(k) were interchanged and rows and
!>               columns k-1 and -IPIV(k-1) were inerchaged,
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>               If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
!>               columns k and -IPIV(k) were interchanged and rows and
!>               columns k+1 and -IPIV(k+1) were inerchaged,
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK)).
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK >=1.  For best performance
!>          LWORK >= N*NB, where NB is the block size returned by ILAENV.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[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) is exactly zero.  The factorization
!>                has been completed, but the block diagonal matrix D is
!>                exactly singular, and division by zero will occur if it
!>                is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', then A = U*D*U**T, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>
Contributors:
!>
!>   June 2016, 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 207 of file csytrf_rook.f.

208*
209* -- LAPACK computational routine --
210* -- LAPACK is a software package provided by Univ. of Tennessee, --
211* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
212*
213* .. Scalar Arguments ..
214 CHARACTER UPLO
215 INTEGER INFO, LDA, LWORK, N
216* ..
217* .. Array Arguments ..
218 INTEGER IPIV( * )
219 COMPLEX A( LDA, * ), WORK( * )
220* ..
221*
222* =====================================================================
223*
224* .. Local Scalars ..
225 LOGICAL LQUERY, UPPER
226 INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
227* ..
228* .. External Functions ..
229 LOGICAL LSAME
230 INTEGER ILAENV
231 EXTERNAL lsame, ilaenv
232* ..
233* .. External Subroutines ..
234 EXTERNAL clasyf_rook, csytf2_rook, xerbla
235* ..
236* .. Intrinsic Functions ..
237 INTRINSIC max
238* ..
239* .. Executable Statements ..
240*
241* Test the input parameters.
242*
243 info = 0
244 upper = lsame( uplo, 'U' )
245 lquery = ( lwork.EQ.-1 )
246 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
247 info = -1
248 ELSE IF( n.LT.0 ) THEN
249 info = -2
250 ELSE IF( lda.LT.max( 1, n ) ) THEN
251 info = -4
252 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
253 info = -7
254 END IF
255*
256 IF( info.EQ.0 ) THEN
257*
258* Determine the block size
259*
260 nb = ilaenv( 1, 'CSYTRF_ROOK', uplo, n, -1, -1, -1 )
261 lwkopt = max( 1, n*nb )
262 work( 1 ) = lwkopt
263 END IF
264*
265 IF( info.NE.0 ) THEN
266 CALL xerbla( 'CSYTRF_ROOK', -info )
267 RETURN
268 ELSE IF( lquery ) THEN
269 RETURN
270 END IF
271*
272 nbmin = 2
273 ldwork = n
274 IF( nb.GT.1 .AND. nb.LT.n ) THEN
275 iws = ldwork*nb
276 IF( lwork.LT.iws ) THEN
277 nb = max( lwork / ldwork, 1 )
278 nbmin = max( 2, ilaenv( 2, 'CSYTRF_ROOK',
279 $ uplo, n, -1, -1, -1 ) )
280 END IF
281 ELSE
282 iws = 1
283 END IF
284 IF( nb.LT.nbmin )
285 $ nb = n
286*
287 IF( upper ) THEN
288*
289* Factorize A as U*D*U**T using the upper triangle of A
290*
291* K is the main loop index, decreasing from N to 1 in steps of
292* KB, where KB is the number of columns factorized by CLASYF_ROOK;
293* KB is either NB or NB-1, or K for the last block
294*
295 k = n
296 10 CONTINUE
297*
298* If K < 1, exit from loop
299*
300 IF( k.LT.1 )
301 $ GO TO 40
302*
303 IF( k.GT.nb ) THEN
304*
305* Factorize columns k-kb+1:k of A and use blocked code to
306* update columns 1:k-kb
307*
308 CALL clasyf_rook( uplo, k, nb, kb, a, lda,
309 $ ipiv, work, ldwork, iinfo )
310 ELSE
311*
312* Use unblocked code to factorize columns 1:k of A
313*
314 CALL csytf2_rook( uplo, k, a, lda, ipiv, iinfo )
315 kb = k
316 END IF
317*
318* Set INFO on the first occurrence of a zero pivot
319*
320 IF( info.EQ.0 .AND. iinfo.GT.0 )
321 $ info = iinfo
322*
323* No need to adjust IPIV
324*
325* Decrease K and return to the start of the main loop
326*
327 k = k - kb
328 GO TO 10
329*
330 ELSE
331*
332* Factorize A as L*D*L**T using the lower triangle of A
333*
334* K is the main loop index, increasing from 1 to N in steps of
335* KB, where KB is the number of columns factorized by CLASYF_ROOK;
336* KB is either NB or NB-1, or N-K+1 for the last block
337*
338 k = 1
339 20 CONTINUE
340*
341* If K > N, exit from loop
342*
343 IF( k.GT.n )
344 $ GO TO 40
345*
346 IF( k.LE.n-nb ) THEN
347*
348* Factorize columns k:k+kb-1 of A and use blocked code to
349* update columns k+kb:n
350*
351 CALL clasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,
352 $ ipiv( k ), work, ldwork, iinfo )
353 ELSE
354*
355* Use unblocked code to factorize columns k:n of A
356*
357 CALL csytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),
358 $ iinfo )
359 kb = n - k + 1
360 END IF
361*
362* Set INFO on the first occurrence of a zero pivot
363*
364 IF( info.EQ.0 .AND. iinfo.GT.0 )
365 $ info = iinfo + k - 1
366*
367* Adjust IPIV
368*
369 DO 30 j = k, k + kb - 1
370 IF( ipiv( j ).GT.0 ) THEN
371 ipiv( j ) = ipiv( j ) + k - 1
372 ELSE
373 ipiv( j ) = ipiv( j ) - k + 1
374 END IF
375 30 CONTINUE
376*
377* Increase K and return to the start of the main loop
378*
379 k = k + kb
380 GO TO 20
381*
382 END IF
383*
384 40 CONTINUE
385 work( 1 ) = lwkopt
386 RETURN
387*
388* End of CSYTRF_ROOK
389*
clasyf_rook
subroutine clasyf_rook(uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Ka...
Definition clasyf_rook.f:184
csytf2_rook
subroutine csytf2_rook(uplo, n, a, lda, ipiv, info)
CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bun...
Definition csytf2_rook.f:194

◆ csytri()

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

CSYTRI

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

Purpose:
!>
!> CSYTRI computes the inverse of a complex symmetric indefinite matrix
!> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
!> CSYTRF.
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX 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 CSYTRF.
!>
!>          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]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by CSYTRF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*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.

Definition at line 113 of file csytri.f.

114*
115* -- LAPACK computational routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 CHARACTER UPLO
121 INTEGER INFO, LDA, N
122* ..
123* .. Array Arguments ..
124 INTEGER IPIV( * )
125 COMPLEX A( LDA, * ), WORK( * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 COMPLEX ONE, ZERO
132 parameter( one = ( 1.0e+0, 0.0e+0 ),
133 $ zero = ( 0.0e+0, 0.0e+0 ) )
134* ..
135* .. Local Scalars ..
136 LOGICAL UPPER
137 INTEGER K, KP, KSTEP
138 COMPLEX AK, AKKP1, AKP1, D, T, TEMP
139* ..
140* .. External Functions ..
141 LOGICAL LSAME
142 COMPLEX CDOTU
143 EXTERNAL lsame, cdotu
144* ..
145* .. External Subroutines ..
146 EXTERNAL ccopy, cswap, csymv, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC abs, max
150* ..
151* .. Executable Statements ..
152*
153* Test the input parameters.
154*
155 info = 0
156 upper = lsame( uplo, 'U' )
157 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
158 info = -1
159 ELSE IF( n.LT.0 ) THEN
160 info = -2
161 ELSE IF( lda.LT.max( 1, n ) ) THEN
162 info = -4
163 END IF
164 IF( info.NE.0 ) THEN
165 CALL xerbla( 'CSYTRI', -info )
166 RETURN
167 END IF
168*
169* Quick return if possible
170*
171 IF( n.EQ.0 )
172 $ RETURN
173*
174* Check that the diagonal matrix D is nonsingular.
175*
176 IF( upper ) THEN
177*
178* Upper triangular storage: examine D from bottom to top
179*
180 DO 10 info = n, 1, -1
181 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
182 $ RETURN
183 10 CONTINUE
184 ELSE
185*
186* Lower triangular storage: examine D from top to bottom.
187*
188 DO 20 info = 1, n
189 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
190 $ RETURN
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 30 CONTINUE
204*
205* If K > N, exit from loop.
206*
207 IF( k.GT.n )
208 $ GO TO 40
209*
210 IF( ipiv( k ).GT.0 ) THEN
211*
212* 1 x 1 diagonal block
213*
214* Invert the diagonal block.
215*
216 a( k, k ) = one / a( k, k )
217*
218* Compute column K of the inverse.
219*
220 IF( k.GT.1 ) THEN
221 CALL ccopy( k-1, a( 1, k ), 1, work, 1 )
222 CALL csymv( uplo, k-1, -one, a, lda, work, 1, zero,
223 $ a( 1, k ), 1 )
224 a( k, k ) = a( k, k ) - cdotu( k-1, work, 1, a( 1, k ),
225 $ 1 )
226 END IF
227 kstep = 1
228 ELSE
229*
230* 2 x 2 diagonal block
231*
232* Invert the diagonal block.
233*
234 t = a( k, k+1 )
235 ak = a( k, k ) / t
236 akp1 = a( k+1, k+1 ) / t
237 akkp1 = a( k, k+1 ) / t
238 d = t*( ak*akp1-one )
239 a( k, k ) = akp1 / d
240 a( k+1, k+1 ) = ak / d
241 a( k, k+1 ) = -akkp1 / d
242*
243* Compute columns K and K+1 of the inverse.
244*
245 IF( k.GT.1 ) THEN
246 CALL ccopy( k-1, a( 1, k ), 1, work, 1 )
247 CALL csymv( uplo, k-1, -one, a, lda, work, 1, zero,
248 $ a( 1, k ), 1 )
249 a( k, k ) = a( k, k ) - cdotu( k-1, work, 1, a( 1, k ),
250 $ 1 )
251 a( k, k+1 ) = a( k, k+1 ) -
252 $ cdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
253 CALL ccopy( k-1, a( 1, k+1 ), 1, work, 1 )
254 CALL csymv( uplo, k-1, -one, a, lda, work, 1, zero,
255 $ a( 1, k+1 ), 1 )
256 a( k+1, k+1 ) = a( k+1, k+1 ) -
257 $ cdotu( k-1, work, 1, a( 1, k+1 ), 1 )
258 END IF
259 kstep = 2
260 END IF
261*
262 kp = abs( ipiv( k ) )
263 IF( kp.NE.k ) THEN
264*
265* Interchange rows and columns K and KP in the leading
266* submatrix A(1:k+1,1:k+1)
267*
268 CALL cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
269 CALL cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda )
270 temp = a( k, k )
271 a( k, k ) = a( kp, kp )
272 a( kp, kp ) = temp
273 IF( kstep.EQ.2 ) THEN
274 temp = a( k, k+1 )
275 a( k, k+1 ) = a( kp, k+1 )
276 a( kp, k+1 ) = temp
277 END IF
278 END IF
279*
280 k = k + kstep
281 GO TO 30
282 40 CONTINUE
283*
284 ELSE
285*
286* Compute inv(A) from the factorization A = L*D*L**T.
287*
288* K is the main loop index, increasing from 1 to N in steps of
289* 1 or 2, depending on the size of the diagonal blocks.
290*
291 k = n
292 50 CONTINUE
293*
294* If K < 1, exit from loop.
295*
296 IF( k.LT.1 )
297 $ GO TO 60
298*
299 IF( ipiv( k ).GT.0 ) THEN
300*
301* 1 x 1 diagonal block
302*
303* Invert the diagonal block.
304*
305 a( k, k ) = one / a( k, k )
306*
307* Compute column K of the inverse.
308*
309 IF( k.LT.n ) THEN
310 CALL ccopy( n-k, a( k+1, k ), 1, work, 1 )
311 CALL csymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1,
312 $ zero, a( k+1, k ), 1 )
313 a( k, k ) = a( k, k ) - cdotu( n-k, work, 1, a( k+1, k ),
314 $ 1 )
315 END IF
316 kstep = 1
317 ELSE
318*
319* 2 x 2 diagonal block
320*
321* Invert the diagonal block.
322*
323 t = a( k, k-1 )
324 ak = a( k-1, k-1 ) / t
325 akp1 = a( k, k ) / t
326 akkp1 = a( k, k-1 ) / t
327 d = t*( ak*akp1-one )
328 a( k-1, k-1 ) = akp1 / d
329 a( k, k ) = ak / d
330 a( k, k-1 ) = -akkp1 / d
331*
332* Compute columns K-1 and K of the inverse.
333*
334 IF( k.LT.n ) THEN
335 CALL ccopy( n-k, a( k+1, k ), 1, work, 1 )
336 CALL csymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1,
337 $ zero, a( k+1, k ), 1 )
338 a( k, k ) = a( k, k ) - cdotu( n-k, work, 1, a( k+1, k ),
339 $ 1 )
340 a( k, k-1 ) = a( k, k-1 ) -
341 $ cdotu( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
342 $ 1 )
343 CALL ccopy( n-k, a( k+1, k-1 ), 1, work, 1 )
344 CALL csymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1,
345 $ zero, a( k+1, k-1 ), 1 )
346 a( k-1, k-1 ) = a( k-1, k-1 ) -
347 $ cdotu( n-k, work, 1, a( k+1, k-1 ), 1 )
348 END IF
349 kstep = 2
350 END IF
351*
352 kp = abs( ipiv( k ) )
353 IF( kp.NE.k ) THEN
354*
355* Interchange rows and columns K and KP in the trailing
356* submatrix A(k-1:n,k-1:n)
357*
358 IF( kp.LT.n )
359 $ CALL cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
360 CALL cswap( kp-k-1, a( k+1, k ), 1, a( kp, k+1 ), lda )
361 temp = a( k, k )
362 a( k, k ) = a( kp, kp )
363 a( kp, kp ) = temp
364 IF( kstep.EQ.2 ) THEN
365 temp = a( k, k-1 )
366 a( k, k-1 ) = a( kp, k-1 )
367 a( kp, k-1 ) = temp
368 END IF
369 END IF
370*
371 k = k - kstep
372 GO TO 50
373 60 CONTINUE
374 END IF
375*
376 RETURN
377*
378* End of CSYTRI
379*
cdotu
complex function cdotu(n, cx, incx, cy, incy)
CDOTU
Definition cdotu.f:83

◆ csytri2()

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

CSYTRI2

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

Purpose:
!>
!> CSYTRI2 computes the inverse of a COMPLEX symmetric indefinite matrix
!> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
!> CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace
!> before calling CSYTRI2X that actually computes the inverse.
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX 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 CSYTRF.
!>
!>          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]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by CSYTRF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N+NB+1)*(NB+3)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          WORK is size >= (N+NB+1)*(NB+3)
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>           calculates:
!>              - the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array,
!>              - and no error message related to LWORK is issued by XERBLA.
!>
[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.

Definition at line 126 of file csytri2.f.

127*
128* -- LAPACK computational routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER INFO, LDA, LWORK, N
135* ..
136* .. Array Arguments ..
137 INTEGER IPIV( * )
138 COMPLEX A( LDA, * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Local Scalars ..
144 LOGICAL UPPER, LQUERY
145 INTEGER MINSIZE, NBMAX
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 INTEGER ILAENV
150 EXTERNAL lsame, ilaenv
151* ..
152* .. External Subroutines ..
153 EXTERNAL csytri, csytri2x, xerbla
154* ..
155* .. Executable Statements ..
156*
157* Test the input parameters.
158*
159 info = 0
160 upper = lsame( uplo, 'U' )
161 lquery = ( lwork.EQ.-1 )
162* Get blocksize
163 nbmax = ilaenv( 1, 'CSYTRI2', uplo, n, -1, -1, -1 )
164 IF ( nbmax .GE. n ) THEN
165 minsize = n
166 ELSE
167 minsize = (n+nbmax+1)*(nbmax+3)
168 END IF
169*
170 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
171 info = -1
172 ELSE IF( n.LT.0 ) THEN
173 info = -2
174 ELSE IF( lda.LT.max( 1, n ) ) THEN
175 info = -4
176 ELSE IF (lwork .LT. minsize .AND. .NOT.lquery ) THEN
177 info = -7
178 END IF
179*
180* Quick return if possible
181*
182*
183 IF( info.NE.0 ) THEN
184 CALL xerbla( 'CSYTRI2', -info )
185 RETURN
186 ELSE IF( lquery ) THEN
187 work(1)=minsize
188 RETURN
189 END IF
190 IF( n.EQ.0 )
191 $ RETURN
192
193 IF( nbmax .GE. n ) THEN
194 CALL csytri( uplo, n, a, lda, ipiv, work, info )
195 ELSE
196 CALL csytri2x( uplo, n, a, lda, ipiv, work, nbmax, info )
197 END IF
198 RETURN
199*
200* End of CSYTRI2
201*
csytri2x
subroutine csytri2x(uplo, n, a, lda, ipiv, work, nb, info)
CSYTRI2X
Definition csytri2x.f:120
csytri
subroutine csytri(uplo, n, a, lda, ipiv, work, info)
CSYTRI
Definition csytri.f:114

◆ csytri2x()

subroutine csytri2x ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( n+nb+1,* ) work,
integer nb,
integer info )

CSYTRI2X

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

Purpose:
!>
!> CSYTRI2X computes the inverse of a real symmetric indefinite matrix
!> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
!> CSYTRF.
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the NNB diagonal matrix D and the multipliers
!>          used to obtain the factor U or L as computed by CSYTRF.
!>
!>          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]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the NNB structure of D
!>          as determined by CSYTRF.
!>
[out]WORK
!>          WORK is COMPLEX 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.

Definition at line 119 of file csytri2x.f.

120*
121* -- LAPACK computational routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 CHARACTER UPLO
127 INTEGER INFO, LDA, N, NB
128* ..
129* .. Array Arguments ..
130 INTEGER IPIV( * )
131 COMPLEX A( LDA, * ), WORK( N+NB+1,* )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX ONE, ZERO
138 parameter( one = ( 1.0e+0, 0.0e+0 ),
139 $ zero = ( 0.0e+0, 0.0e+0 ) )
140* ..
141* .. Local Scalars ..
142 LOGICAL UPPER
143 INTEGER I, IINFO, IP, K, CUT, NNB
144 INTEGER COUNT
145 INTEGER J, U11, INVD
146
147 COMPLEX AK, AKKP1, AKP1, D, T
148 COMPLEX U01_I_J, U01_IP1_J
149 COMPLEX U11_I_J, U11_IP1_J
150* ..
151* .. External Functions ..
152 LOGICAL LSAME
153 EXTERNAL lsame
154* ..
155* .. External Subroutines ..
156 EXTERNAL csyconv, xerbla, ctrtri
157 EXTERNAL cgemm, ctrmm, csyswapr
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max
161* ..
162* .. Executable Statements ..
163*
164* Test the input parameters.
165*
166 info = 0
167 upper = lsame( uplo, 'U' )
168 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
169 info = -1
170 ELSE IF( n.LT.0 ) THEN
171 info = -2
172 ELSE IF( lda.LT.max( 1, n ) ) THEN
173 info = -4
174 END IF
175*
176* Quick return if possible
177*
178*
179 IF( info.NE.0 ) THEN
180 CALL xerbla( 'CSYTRI2X', -info )
181 RETURN
182 END IF
183 IF( n.EQ.0 )
184 $ RETURN
185*
186* Convert A
187* Workspace got Non-diag elements of D
188*
189 CALL csyconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
190*
191* Check that the diagonal matrix D is nonsingular.
192*
193 IF( upper ) THEN
194*
195* Upper triangular storage: examine D from bottom to top
196*
197 DO info = n, 1, -1
198 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
199 $ RETURN
200 END DO
201 ELSE
202*
203* Lower triangular storage: examine D from top to bottom.
204*
205 DO info = 1, n
206 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
207 $ RETURN
208 END DO
209 END IF
210 info = 0
211*
212* Splitting Workspace
213* U01 is a block (N,NB+1)
214* The first element of U01 is in WORK(1,1)
215* U11 is a block (NB+1,NB+1)
216* The first element of U11 is in WORK(N+1,1)
217 u11 = n
218* INVD is a block (N,2)
219* The first element of INVD is in WORK(1,INVD)
220 invd = nb+2
221
222 IF( upper ) THEN
223*
224* invA = P * inv(U**T)*inv(D)*inv(U)*P**T.
225*
226 CALL ctrtri( uplo, 'U', n, a, lda, info )
227*
228* inv(D) and inv(D)*inv(U)
229*
230 k=1
231 DO WHILE ( k .LE. n )
232 IF( ipiv( k ).GT.0 ) THEN
233* 1 x 1 diagonal NNB
234 work(k,invd) = one / a( k, k )
235 work(k,invd+1) = 0
236 k=k+1
237 ELSE
238* 2 x 2 diagonal NNB
239 t = work(k+1,1)
240 ak = a( k, k ) / t
241 akp1 = a( k+1, k+1 ) / t
242 akkp1 = work(k+1,1) / t
243 d = t*( ak*akp1-one )
244 work(k,invd) = akp1 / d
245 work(k+1,invd+1) = ak / d
246 work(k,invd+1) = -akkp1 / d
247 work(k+1,invd) = -akkp1 / d
248 k=k+2
249 END IF
250 END DO
251*
252* inv(U**T) = (inv(U))**T
253*
254* inv(U**T)*inv(D)*inv(U)
255*
256 cut=n
257 DO WHILE (cut .GT. 0)
258 nnb=nb
259 IF (cut .LE. nnb) THEN
260 nnb=cut
261 ELSE
262 count = 0
263* count negative elements,
264 DO i=cut+1-nnb,cut
265 IF (ipiv(i) .LT. 0) count=count+1
266 END DO
267* need a even number for a clear cut
268 IF (mod(count,2) .EQ. 1) nnb=nnb+1
269 END IF
270
271 cut=cut-nnb
272*
273* U01 Block
274*
275 DO i=1,cut
276 DO j=1,nnb
277 work(i,j)=a(i,cut+j)
278 END DO
279 END DO
280*
281* U11 Block
282*
283 DO i=1,nnb
284 work(u11+i,i)=one
285 DO j=1,i-1
286 work(u11+i,j)=zero
287 END DO
288 DO j=i+1,nnb
289 work(u11+i,j)=a(cut+i,cut+j)
290 END DO
291 END DO
292*
293* invD*U01
294*
295 i=1
296 DO WHILE (i .LE. cut)
297 IF (ipiv(i) > 0) THEN
298 DO j=1,nnb
299 work(i,j)=work(i,invd)*work(i,j)
300 END DO
301 i=i+1
302 ELSE
303 DO j=1,nnb
304 u01_i_j = work(i,j)
305 u01_ip1_j = work(i+1,j)
306 work(i,j)=work(i,invd)*u01_i_j+
307 $ work(i,invd+1)*u01_ip1_j
308 work(i+1,j)=work(i+1,invd)*u01_i_j+
309 $ work(i+1,invd+1)*u01_ip1_j
310 END DO
311 i=i+2
312 END IF
313 END DO
314*
315* invD1*U11
316*
317 i=1
318 DO WHILE (i .LE. nnb)
319 IF (ipiv(cut+i) > 0) THEN
320 DO j=i,nnb
321 work(u11+i,j)=work(cut+i,invd)*work(u11+i,j)
322 END DO
323 i=i+1
324 ELSE
325 DO j=i,nnb
326 u11_i_j = work(u11+i,j)
327 u11_ip1_j = work(u11+i+1,j)
328 work(u11+i,j)=work(cut+i,invd)*work(u11+i,j) +
329 $ work(cut+i,invd+1)*work(u11+i+1,j)
330 work(u11+i+1,j)=work(cut+i+1,invd)*u11_i_j+
331 $ work(cut+i+1,invd+1)*u11_ip1_j
332 END DO
333 i=i+2
334 END IF
335 END DO
336*
337* U11**T*invD1*U11->U11
338*
339 CALL ctrmm('L','U','T','U',nnb, nnb,
340 $ one,a(cut+1,cut+1),lda,work(u11+1,1),n+nb+1)
341*
342 DO i=1,nnb
343 DO j=i,nnb
344 a(cut+i,cut+j)=work(u11+i,j)
345 END DO
346 END DO
347*
348* U01**T*invD*U01->A(CUT+I,CUT+J)
349*
350 CALL cgemm('T','N',nnb,nnb,cut,one,a(1,cut+1),lda,
351 $ work,n+nb+1, zero, work(u11+1,1), n+nb+1)
352*
353* U11 = U11**T*invD1*U11 + U01**T*invD*U01
354*
355 DO i=1,nnb
356 DO j=i,nnb
357 a(cut+i,cut+j)=a(cut+i,cut+j)+work(u11+i,j)
358 END DO
359 END DO
360*
361* U01 = U00**T*invD0*U01
362*
363 CALL ctrmm('L',uplo,'T','U',cut, nnb,
364 $ one,a,lda,work,n+nb+1)
365
366*
367* Update U01
368*
369 DO i=1,cut
370 DO j=1,nnb
371 a(i,cut+j)=work(i,j)
372 END DO
373 END DO
374*
375* Next Block
376*
377 END DO
378*
379* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T
380*
381 i=1
382 DO WHILE ( i .LE. n )
383 IF( ipiv(i) .GT. 0 ) THEN
384 ip=ipiv(i)
385 IF (i .LT. ip) CALL csyswapr( uplo, n, a, lda, i ,ip )
386 IF (i .GT. ip) CALL csyswapr( uplo, n, a, lda, ip ,i )
387 ELSE
388 ip=-ipiv(i)
389 i=i+1
390 IF ( (i-1) .LT. ip)
391 $ CALL csyswapr( uplo, n, a, lda, i-1 ,ip )
392 IF ( (i-1) .GT. ip)
393 $ CALL csyswapr( uplo, n, a, lda, ip ,i-1 )
394 ENDIF
395 i=i+1
396 END DO
397 ELSE
398*
399* LOWER...
400*
401* invA = P * inv(U**T)*inv(D)*inv(U)*P**T.
402*
403 CALL ctrtri( uplo, 'U', n, a, lda, info )
404*
405* inv(D) and inv(D)*inv(U)
406*
407 k=n
408 DO WHILE ( k .GE. 1 )
409 IF( ipiv( k ).GT.0 ) THEN
410* 1 x 1 diagonal NNB
411 work(k,invd) = one / a( k, k )
412 work(k,invd+1) = 0
413 k=k-1
414 ELSE
415* 2 x 2 diagonal NNB
416 t = work(k-1,1)
417 ak = a( k-1, k-1 ) / t
418 akp1 = a( k, k ) / t
419 akkp1 = work(k-1,1) / t
420 d = t*( ak*akp1-one )
421 work(k-1,invd) = akp1 / d
422 work(k,invd) = ak / d
423 work(k,invd+1) = -akkp1 / d
424 work(k-1,invd+1) = -akkp1 / d
425 k=k-2
426 END IF
427 END DO
428*
429* inv(U**T) = (inv(U))**T
430*
431* inv(U**T)*inv(D)*inv(U)
432*
433 cut=0
434 DO WHILE (cut .LT. n)
435 nnb=nb
436 IF (cut + nnb .GE. n) THEN
437 nnb=n-cut
438 ELSE
439 count = 0
440* count negative elements,
441 DO i=cut+1,cut+nnb
442 IF (ipiv(i) .LT. 0) count=count+1
443 END DO
444* need a even number for a clear cut
445 IF (mod(count,2) .EQ. 1) nnb=nnb+1
446 END IF
447* L21 Block
448 DO i=1,n-cut-nnb
449 DO j=1,nnb
450 work(i,j)=a(cut+nnb+i,cut+j)
451 END DO
452 END DO
453* L11 Block
454 DO i=1,nnb
455 work(u11+i,i)=one
456 DO j=i+1,nnb
457 work(u11+i,j)=zero
458 END DO
459 DO j=1,i-1
460 work(u11+i,j)=a(cut+i,cut+j)
461 END DO
462 END DO
463*
464* invD*L21
465*
466 i=n-cut-nnb
467 DO WHILE (i .GE. 1)
468 IF (ipiv(cut+nnb+i) > 0) THEN
469 DO j=1,nnb
470 work(i,j)=work(cut+nnb+i,invd)*work(i,j)
471 END DO
472 i=i-1
473 ELSE
474 DO j=1,nnb
475 u01_i_j = work(i,j)
476 u01_ip1_j = work(i-1,j)
477 work(i,j)=work(cut+nnb+i,invd)*u01_i_j+
478 $ work(cut+nnb+i,invd+1)*u01_ip1_j
479 work(i-1,j)=work(cut+nnb+i-1,invd+1)*u01_i_j+
480 $ work(cut+nnb+i-1,invd)*u01_ip1_j
481 END DO
482 i=i-2
483 END IF
484 END DO
485*
486* invD1*L11
487*
488 i=nnb
489 DO WHILE (i .GE. 1)
490 IF (ipiv(cut+i) > 0) THEN
491 DO j=1,nnb
492 work(u11+i,j)=work(cut+i,invd)*work(u11+i,j)
493 END DO
494 i=i-1
495 ELSE
496 DO j=1,nnb
497 u11_i_j = work(u11+i,j)
498 u11_ip1_j = work(u11+i-1,j)
499 work(u11+i,j)=work(cut+i,invd)*work(u11+i,j) +
500 $ work(cut+i,invd+1)*u11_ip1_j
501 work(u11+i-1,j)=work(cut+i-1,invd+1)*u11_i_j+
502 $ work(cut+i-1,invd)*u11_ip1_j
503 END DO
504 i=i-2
505 END IF
506 END DO
507*
508* L11**T*invD1*L11->L11
509*
510 CALL ctrmm('L',uplo,'T','U',nnb, nnb,
511 $ one,a(cut+1,cut+1),lda,work(u11+1,1),n+nb+1)
512*
513 DO i=1,nnb
514 DO j=1,i
515 a(cut+i,cut+j)=work(u11+i,j)
516 END DO
517 END DO
518*
519 IF ( (cut+nnb) .LT. n ) THEN
520*
521* L21**T*invD2*L21->A(CUT+I,CUT+J)
522*
523 CALL cgemm('T','N',nnb,nnb,n-nnb-cut,one,a(cut+nnb+1,cut+1)
524 $ ,lda,work,n+nb+1, zero, work(u11+1,1), n+nb+1)
525
526*
527* L11 = L11**T*invD1*L11 + U01**T*invD*U01
528*
529 DO i=1,nnb
530 DO j=1,i
531 a(cut+i,cut+j)=a(cut+i,cut+j)+work(u11+i,j)
532 END DO
533 END DO
534*
535* L01 = L22**T*invD2*L21
536*
537 CALL ctrmm('L',uplo,'T','U', n-nnb-cut, nnb,
538 $ one,a(cut+nnb+1,cut+nnb+1),lda,work,n+nb+1)
539
540* Update L21
541 DO i=1,n-cut-nnb
542 DO j=1,nnb
543 a(cut+nnb+i,cut+j)=work(i,j)
544 END DO
545 END DO
546 ELSE
547*
548* L11 = L11**T*invD1*L11
549*
550 DO i=1,nnb
551 DO j=1,i
552 a(cut+i,cut+j)=work(u11+i,j)
553 END DO
554 END DO
555 END IF
556*
557* Next Block
558*
559 cut=cut+nnb
560 END DO
561*
562* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T
563*
564 i=n
565 DO WHILE ( i .GE. 1 )
566 IF( ipiv(i) .GT. 0 ) THEN
567 ip=ipiv(i)
568 IF (i .LT. ip) CALL csyswapr( uplo, n, a, lda, i ,ip )
569 IF (i .GT. ip) CALL csyswapr( uplo, n, a, lda, ip ,i )
570 ELSE
571 ip=-ipiv(i)
572 IF ( i .LT. ip) CALL csyswapr( uplo, n, a, lda, i ,ip )
573 IF ( i .GT. ip) CALL csyswapr( uplo, n, a, lda, ip ,i )
574 i=i-1
575 ENDIF
576 i=i-1
577 END DO
578 END IF
579*
580 RETURN
581*
582* End of CSYTRI2X
583*
ctrtri
subroutine ctrtri(uplo, diag, n, a, lda, info)
CTRTRI
Definition ctrtri.f:109
csyswapr
subroutine csyswapr(uplo, n, a, lda, i1, i2)
CSYSWAPR
Definition csyswapr.f:102
csyconv
subroutine csyconv(uplo, way, n, a, lda, ipiv, e, info)
CSYCONV
Definition csyconv.f:114
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177

◆ csytri_3()

subroutine csytri_3 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( * ) work,
integer lwork,
integer info )

CSYTRI_3

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

Purpose:
!> CSYTRI_3 computes the inverse of a complex symmetric indefinite
!> matrix A using the factorization computed by CSYTRF_RK or CSYTRF_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.
!>
!> CSYTRI_3 sets the leading dimension of the workspace  before calling
!> CSYTRI_3X that actually computes the inverse.  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 COMPLEX array, dimension (LDA,N)
!>          On entry, diagonal of the block diagonal matrix D and
!>          factors U or L as computed by CSYTRF_RK and CSYTRF_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 COMPLEX 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 referenced;
!>          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 CSYTRF_RK or CSYTRF_BK.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N+NB+1)*(NB+3).
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK. LWORK >= (N+NB+1)*(NB+3).
!>
!>          If LDWORK = -1, then a workspace query is assumed;
!>          the routine only calculates the optimal size of the optimal
!>          size of the WORK array, returns this value as the first
!>          entry of the WORK array, and no error message related to
!>          LWORK is issued by XERBLA.
!>
[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 2017,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>

Definition at line 168 of file csytri_3.f.

170*
171* -- LAPACK computational routine --
172* -- LAPACK is a software package provided by Univ. of Tennessee, --
173* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
174*
175* .. Scalar Arguments ..
176 CHARACTER UPLO
177 INTEGER INFO, LDA, LWORK, N
178* ..
179* .. Array Arguments ..
180 INTEGER IPIV( * )
181 COMPLEX A( LDA, * ), E( * ), WORK( * )
182* ..
183*
184* =====================================================================
185*
186* .. Local Scalars ..
187 LOGICAL UPPER, LQUERY
188 INTEGER LWKOPT, NB
189* ..
190* .. External Functions ..
191 LOGICAL LSAME
192 INTEGER ILAENV
193 EXTERNAL lsame, ilaenv
194* ..
195* .. External Subroutines ..
196 EXTERNAL csytri_3x, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC max
200* ..
201* .. Executable Statements ..
202*
203* Test the input parameters.
204*
205 info = 0
206 upper = lsame( uplo, 'U' )
207 lquery = ( lwork.EQ.-1 )
208*
209* Determine the block size
210*
211 nb = max( 1, ilaenv( 1, 'CSYTRI_3', uplo, n, -1, -1, -1 ) )
212 lwkopt = ( n+nb+1 ) * ( nb+3 )
213*
214 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
215 info = -1
216 ELSE IF( n.LT.0 ) THEN
217 info = -2
218 ELSE IF( lda.LT.max( 1, n ) ) THEN
219 info = -4
220 ELSE IF ( lwork .LT. lwkopt .AND. .NOT.lquery ) THEN
221 info = -8
222 END IF
223*
224 IF( info.NE.0 ) THEN
225 CALL xerbla( 'CSYTRI_3', -info )
226 RETURN
227 ELSE IF( lquery ) THEN
228 work( 1 ) = lwkopt
229 RETURN
230 END IF
231*
232* Quick return if possible
233*
234 IF( n.EQ.0 )
235 $ RETURN
236*
237 CALL csytri_3x( uplo, n, a, lda, e, ipiv, work, nb, info )
238*
239 work( 1 ) = lwkopt
240*
241 RETURN
242*
243* End of CSYTRI_3
244*
csytri_3x
subroutine csytri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
CSYTRI_3X
Definition csytri_3x.f:159

◆ csytri_3x()

subroutine csytri_3x ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( n+nb+1, * ) work,
integer nb,
integer info )

CSYTRI_3X

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

Purpose:
!> CSYTRI_3X computes the inverse of a complex symmetric indefinite
!> matrix A using the factorization computed by CSYTRF_RK or CSYTRF_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 COMPLEX array, dimension (LDA,N)
!>          On entry, diagonal of the block diagonal matrix D and
!>          factors U or L as computed by CSYTRF_RK and CSYTRF_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 COMPLEX 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 referenced;
!>          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 CSYTRF_RK or CSYTRF_BK.
!>
[out]WORK
!>          WORK is COMPLEX 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.
Contributors:
!>
!>  June 2017,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>

Definition at line 158 of file csytri_3x.f.

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

◆ csytri_rook()

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

CSYTRI_ROOK

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

Purpose:
!>
!> CSYTRI_ROOK computes the inverse of a complex symmetric
!> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!> computed by CSYTRF_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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX 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 CSYTRF_ROOK.
!>
!>          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]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by CSYTRF_ROOK.
!>
[out]WORK
!>          WORK is COMPLEX 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:
!>
!>   December 2016, 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 128 of file csytri_rook.f.

129*
130* -- LAPACK computational routine --
131* -- LAPACK is a software package provided by Univ. of Tennessee, --
132* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
133*
134* .. Scalar Arguments ..
135 CHARACTER UPLO
136 INTEGER INFO, LDA, N
137* ..
138* .. Array Arguments ..
139 INTEGER IPIV( * )
140 COMPLEX A( LDA, * ), WORK( * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 COMPLEX CONE, CZERO
147 parameter( cone = ( 1.0e+0, 0.0e+0 ),
148 $ czero = ( 0.0e+0, 0.0e+0 ) )
149* ..
150* .. Local Scalars ..
151 LOGICAL UPPER
152 INTEGER K, KP, KSTEP
153 COMPLEX AK, AKKP1, AKP1, D, T, TEMP
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 COMPLEX CDOTU
158 EXTERNAL lsame, cdotu
159* ..
160* .. External Subroutines ..
161 EXTERNAL ccopy, cswap, csymv, xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC max
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 upper = lsame( uplo, 'U' )
172 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
173 info = -1
174 ELSE IF( n.LT.0 ) THEN
175 info = -2
176 ELSE IF( lda.LT.max( 1, n ) ) THEN
177 info = -4
178 END IF
179 IF( info.NE.0 ) THEN
180 CALL xerbla( 'CSYTRI_ROOK', -info )
181 RETURN
182 END IF
183*
184* Quick return if possible
185*
186 IF( n.EQ.0 )
187 $ RETURN
188*
189* Check that the diagonal matrix D is nonsingular.
190*
191 IF( upper ) THEN
192*
193* Upper triangular storage: examine D from bottom to top
194*
195 DO 10 info = n, 1, -1
196 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.czero )
197 $ RETURN
198 10 CONTINUE
199 ELSE
200*
201* Lower triangular storage: examine D from top to bottom.
202*
203 DO 20 info = 1, n
204 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.czero )
205 $ RETURN
206 20 CONTINUE
207 END IF
208 info = 0
209*
210 IF( upper ) THEN
211*
212* Compute inv(A) from the factorization A = U*D*U**T.
213*
214* K is the main loop index, increasing from 1 to N in steps of
215* 1 or 2, depending on the size of the diagonal blocks.
216*
217 k = 1
218 30 CONTINUE
219*
220* If K > N, exit from loop.
221*
222 IF( k.GT.n )
223 $ GO TO 40
224*
225 IF( ipiv( k ).GT.0 ) THEN
226*
227* 1 x 1 diagonal block
228*
229* Invert the diagonal block.
230*
231 a( k, k ) = cone / a( k, k )
232*
233* Compute column K of the inverse.
234*
235 IF( k.GT.1 ) THEN
236 CALL ccopy( k-1, a( 1, k ), 1, work, 1 )
237 CALL csymv( uplo, k-1, -cone, a, lda, work, 1, czero,
238 $ a( 1, k ), 1 )
239 a( k, k ) = a( k, k ) - cdotu( k-1, work, 1, a( 1, k ),
240 $ 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 = a( k, k+1 )
250 ak = a( k, k ) / t
251 akp1 = a( k+1, k+1 ) / t
252 akkp1 = a( k, k+1 ) / t
253 d = t*( ak*akp1-cone )
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 ccopy( k-1, a( 1, k ), 1, work, 1 )
262 CALL csymv( uplo, k-1, -cone, a, lda, work, 1, czero,
263 $ a( 1, k ), 1 )
264 a( k, k ) = a( k, k ) - cdotu( k-1, work, 1, a( 1, k ),
265 $ 1 )
266 a( k, k+1 ) = a( k, k+1 ) -
267 $ cdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
268 CALL ccopy( k-1, a( 1, k+1 ), 1, work, 1 )
269 CALL csymv( uplo, k-1, -cone, a, lda, work, 1, czero,
270 $ a( 1, k+1 ), 1 )
271 a( k+1, k+1 ) = a( k+1, k+1 ) -
272 $ cdotu( k-1, work, 1, a( 1, k+1 ), 1 )
273 END IF
274 kstep = 2
275 END IF
276*
277 IF( kstep.EQ.1 ) THEN
278*
279* Interchange rows and columns K and IPIV(K) in the leading
280* submatrix A(1:k+1,1:k+1)
281*
282 kp = ipiv( k )
283 IF( kp.NE.k ) THEN
284 IF( kp.GT.1 )
285 $ CALL cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
286 CALL cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda )
287 temp = a( k, k )
288 a( k, k ) = a( kp, kp )
289 a( kp, kp ) = temp
290 END IF
291 ELSE
292*
293* Interchange rows and columns K and K+1 with -IPIV(K) and
294* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1)
295*
296 kp = -ipiv( k )
297 IF( kp.NE.k ) THEN
298 IF( kp.GT.1 )
299 $ CALL cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
300 CALL cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda )
301*
302 temp = a( k, k )
303 a( k, k ) = a( kp, kp )
304 a( kp, kp ) = temp
305 temp = a( k, k+1 )
306 a( k, k+1 ) = a( kp, k+1 )
307 a( kp, k+1 ) = temp
308 END IF
309*
310 k = k + 1
311 kp = -ipiv( k )
312 IF( kp.NE.k ) THEN
313 IF( kp.GT.1 )
314 $ CALL cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
315 CALL cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda )
316 temp = a( k, k )
317 a( k, k ) = a( kp, kp )
318 a( kp, kp ) = temp
319 END IF
320 END IF
321*
322 k = k + 1
323 GO TO 30
324 40 CONTINUE
325*
326 ELSE
327*
328* Compute inv(A) from the factorization A = L*D*L**T.
329*
330* K is the main loop index, increasing from 1 to N in steps of
331* 1 or 2, depending on the size of the diagonal blocks.
332*
333 k = n
334 50 CONTINUE
335*
336* If K < 1, exit from loop.
337*
338 IF( k.LT.1 )
339 $ GO TO 60
340*
341 IF( ipiv( k ).GT.0 ) THEN
342*
343* 1 x 1 diagonal block
344*
345* Invert the diagonal block.
346*
347 a( k, k ) = cone / a( k, k )
348*
349* Compute column K of the inverse.
350*
351 IF( k.LT.n ) THEN
352 CALL ccopy( n-k, a( k+1, k ), 1, work, 1 )
353 CALL csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1,
354 $ czero, a( k+1, k ), 1 )
355 a( k, k ) = a( k, k ) - cdotu( n-k, work, 1, a( k+1, k ),
356 $ 1 )
357 END IF
358 kstep = 1
359 ELSE
360*
361* 2 x 2 diagonal block
362*
363* Invert the diagonal block.
364*
365 t = a( k, k-1 )
366 ak = a( k-1, k-1 ) / t
367 akp1 = a( k, k ) / t
368 akkp1 = a( k, k-1 ) / t
369 d = t*( ak*akp1-cone )
370 a( k-1, k-1 ) = akp1 / d
371 a( k, k ) = ak / d
372 a( k, k-1 ) = -akkp1 / d
373*
374* Compute columns K-1 and K of the inverse.
375*
376 IF( k.LT.n ) THEN
377 CALL ccopy( n-k, a( k+1, k ), 1, work, 1 )
378 CALL csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1,
379 $ czero, a( k+1, k ), 1 )
380 a( k, k ) = a( k, k ) - cdotu( n-k, work, 1, a( k+1, k ),
381 $ 1 )
382 a( k, k-1 ) = a( k, k-1 ) -
383 $ cdotu( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
384 $ 1 )
385 CALL ccopy( n-k, a( k+1, k-1 ), 1, work, 1 )
386 CALL csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1,
387 $ czero, a( k+1, k-1 ), 1 )
388 a( k-1, k-1 ) = a( k-1, k-1 ) -
389 $ cdotu( n-k, work, 1, a( k+1, k-1 ), 1 )
390 END IF
391 kstep = 2
392 END IF
393*
394 IF( kstep.EQ.1 ) THEN
395*
396* Interchange rows and columns K and IPIV(K) in the trailing
397* submatrix A(k-1:n,k-1:n)
398*
399 kp = ipiv( k )
400 IF( kp.NE.k ) THEN
401 IF( kp.LT.n )
402 $ CALL cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
403 CALL cswap( kp-k-1, a( k+1, k ), 1, a( kp, k+1 ), lda )
404 temp = a( k, k )
405 a( k, k ) = a( kp, kp )
406 a( kp, kp ) = temp
407 END IF
408 ELSE
409*
410* Interchange rows and columns K and K-1 with -IPIV(K) and
411* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n)
412*
413 kp = -ipiv( k )
414 IF( kp.NE.k ) THEN
415 IF( kp.LT.n )
416 $ CALL cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
417 CALL cswap( kp-k-1, a( k+1, k ), 1, a( kp, k+1 ), lda )
418*
419 temp = a( k, k )
420 a( k, k ) = a( kp, kp )
421 a( kp, kp ) = temp
422 temp = a( k, k-1 )
423 a( k, k-1 ) = a( kp, k-1 )
424 a( kp, k-1 ) = temp
425 END IF
426*
427 k = k - 1
428 kp = -ipiv( k )
429 IF( kp.NE.k ) THEN
430 IF( kp.LT.n )
431 $ CALL cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
432 CALL cswap( kp-k-1, a( k+1, k ), 1, a( kp, k+1 ), lda )
433 temp = a( k, k )
434 a( k, k ) = a( kp, kp )
435 a( kp, kp ) = temp
436 END IF
437 END IF
438*
439 k = k - 1
440 GO TO 50
441 60 CONTINUE
442 END IF
443*
444 RETURN
445*
446* End of CSYTRI_ROOK
447*

◆ csytrs()

subroutine csytrs ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
integer info )

CSYTRS

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

Purpose:
!>
!> CSYTRS solves a system of linear equations A*X = B with a complex
!> symmetric matrix A using the factorization A = U*D*U**T or
!> A = L*D*L**T computed by CSYTRF.
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF.
!>
[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 CSYTRF.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file csytrs.f.

120*
121* -- LAPACK computational routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 CHARACTER UPLO
127 INTEGER INFO, LDA, LDB, N, NRHS
128* ..
129* .. Array Arguments ..
130 INTEGER IPIV( * )
131 COMPLEX A( LDA, * ), B( LDB, * )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX ONE
138 parameter( one = ( 1.0e+0, 0.0e+0 ) )
139* ..
140* .. Local Scalars ..
141 LOGICAL UPPER
142 INTEGER J, K, KP
143 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
144* ..
145* .. External Functions ..
146 LOGICAL LSAME
147 EXTERNAL lsame
148* ..
149* .. External Subroutines ..
150 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC max
154* ..
155* .. Executable Statements ..
156*
157 info = 0
158 upper = lsame( uplo, 'U' )
159 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
160 info = -1
161 ELSE IF( n.LT.0 ) THEN
162 info = -2
163 ELSE IF( nrhs.LT.0 ) THEN
164 info = -3
165 ELSE IF( lda.LT.max( 1, n ) ) THEN
166 info = -5
167 ELSE IF( ldb.LT.max( 1, n ) ) THEN
168 info = -8
169 END IF
170 IF( info.NE.0 ) THEN
171 CALL xerbla( 'CSYTRS', -info )
172 RETURN
173 END IF
174*
175* Quick return if possible
176*
177 IF( n.EQ.0 .OR. nrhs.EQ.0 )
178 $ RETURN
179*
180 IF( upper ) THEN
181*
182* Solve A*X = B, where A = U*D*U**T.
183*
184* First solve U*D*X = B, overwriting B with X.
185*
186* K is the main loop index, decreasing from N to 1 in steps of
187* 1 or 2, depending on the size of the diagonal blocks.
188*
189 k = n
190 10 CONTINUE
191*
192* If K < 1, exit from loop.
193*
194 IF( k.LT.1 )
195 $ GO TO 30
196*
197 IF( ipiv( k ).GT.0 ) THEN
198*
199* 1 x 1 diagonal block
200*
201* Interchange rows K and IPIV(K).
202*
203 kp = ipiv( k )
204 IF( kp.NE.k )
205 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
206*
207* Multiply by inv(U(K)), where U(K) is the transformation
208* stored in column K of A.
209*
210 CALL cgeru( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
211 $ b( 1, 1 ), ldb )
212*
213* Multiply by the inverse of the diagonal block.
214*
215 CALL cscal( nrhs, one / a( k, k ), b( k, 1 ), ldb )
216 k = k - 1
217 ELSE
218*
219* 2 x 2 diagonal block
220*
221* Interchange rows K-1 and -IPIV(K).
222*
223 kp = -ipiv( k )
224 IF( kp.NE.k-1 )
225 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
226*
227* Multiply by inv(U(K)), where U(K) is the transformation
228* stored in columns K-1 and K of A.
229*
230 CALL cgeru( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
231 $ b( 1, 1 ), ldb )
232 CALL cgeru( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),
233 $ ldb, b( 1, 1 ), ldb )
234*
235* Multiply by the inverse of the diagonal block.
236*
237 akm1k = a( k-1, k )
238 akm1 = a( k-1, k-1 ) / akm1k
239 ak = a( k, k ) / akm1k
240 denom = akm1*ak - one
241 DO 20 j = 1, nrhs
242 bkm1 = b( k-1, j ) / akm1k
243 bk = b( k, j ) / akm1k
244 b( k-1, j ) = ( ak*bkm1-bk ) / denom
245 b( k, j ) = ( akm1*bk-bkm1 ) / denom
246 20 CONTINUE
247 k = k - 2
248 END IF
249*
250 GO TO 10
251 30 CONTINUE
252*
253* Next solve U**T *X = B, overwriting B with X.
254*
255* K is the main loop index, increasing from 1 to N in steps of
256* 1 or 2, depending on the size of the diagonal blocks.
257*
258 k = 1
259 40 CONTINUE
260*
261* If K > N, exit from loop.
262*
263 IF( k.GT.n )
264 $ GO TO 50
265*
266 IF( ipiv( k ).GT.0 ) THEN
267*
268* 1 x 1 diagonal block
269*
270* Multiply by inv(U**T(K)), where U(K) is the transformation
271* stored in column K of A.
272*
273 CALL cgemv( 'Transpose', k-1, nrhs, -one, b, ldb, a( 1, k ),
274 $ 1, one, b( k, 1 ), ldb )
275*
276* Interchange rows K and IPIV(K).
277*
278 kp = ipiv( k )
279 IF( kp.NE.k )
280 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
281 k = k + 1
282 ELSE
283*
284* 2 x 2 diagonal block
285*
286* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
287* stored in columns K and K+1 of A.
288*
289 CALL cgemv( 'Transpose', k-1, nrhs, -one, b, ldb, a( 1, k ),
290 $ 1, one, b( k, 1 ), ldb )
291 CALL cgemv( 'Transpose', k-1, nrhs, -one, b, ldb,
292 $ a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb )
293*
294* Interchange rows K and -IPIV(K).
295*
296 kp = -ipiv( k )
297 IF( kp.NE.k )
298 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
299 k = k + 2
300 END IF
301*
302 GO TO 40
303 50 CONTINUE
304*
305 ELSE
306*
307* Solve A*X = B, where A = L*D*L**T.
308*
309* First solve L*D*X = B, overwriting B with X.
310*
311* K is the main loop index, increasing from 1 to N in steps of
312* 1 or 2, depending on the size of the diagonal blocks.
313*
314 k = 1
315 60 CONTINUE
316*
317* If K > N, exit from loop.
318*
319 IF( k.GT.n )
320 $ GO TO 80
321*
322 IF( ipiv( k ).GT.0 ) THEN
323*
324* 1 x 1 diagonal block
325*
326* Interchange rows K and IPIV(K).
327*
328 kp = ipiv( k )
329 IF( kp.NE.k )
330 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
331*
332* Multiply by inv(L(K)), where L(K) is the transformation
333* stored in column K of A.
334*
335 IF( k.LT.n )
336 $ CALL cgeru( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ),
337 $ ldb, b( k+1, 1 ), ldb )
338*
339* Multiply by the inverse of the diagonal block.
340*
341 CALL cscal( nrhs, one / a( k, k ), b( k, 1 ), ldb )
342 k = k + 1
343 ELSE
344*
345* 2 x 2 diagonal block
346*
347* Interchange rows K+1 and -IPIV(K).
348*
349 kp = -ipiv( k )
350 IF( kp.NE.k+1 )
351 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
352*
353* Multiply by inv(L(K)), where L(K) is the transformation
354* stored in columns K and K+1 of A.
355*
356 IF( k.LT.n-1 ) THEN
357 CALL cgeru( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
358 $ ldb, b( k+2, 1 ), ldb )
359 CALL cgeru( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
360 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
361 END IF
362*
363* Multiply by the inverse of the diagonal block.
364*
365 akm1k = a( k+1, k )
366 akm1 = a( k, k ) / akm1k
367 ak = a( k+1, k+1 ) / akm1k
368 denom = akm1*ak - one
369 DO 70 j = 1, nrhs
370 bkm1 = b( k, j ) / akm1k
371 bk = b( k+1, j ) / akm1k
372 b( k, j ) = ( ak*bkm1-bk ) / denom
373 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
374 70 CONTINUE
375 k = k + 2
376 END IF
377*
378 GO TO 60
379 80 CONTINUE
380*
381* Next solve L**T *X = B, overwriting B with X.
382*
383* K is the main loop index, decreasing from N to 1 in steps of
384* 1 or 2, depending on the size of the diagonal blocks.
385*
386 k = n
387 90 CONTINUE
388*
389* If K < 1, exit from loop.
390*
391 IF( k.LT.1 )
392 $ GO TO 100
393*
394 IF( ipiv( k ).GT.0 ) THEN
395*
396* 1 x 1 diagonal block
397*
398* Multiply by inv(L**T(K)), where L(K) is the transformation
399* stored in column K of A.
400*
401 IF( k.LT.n )
402 $ CALL cgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
403 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
404*
405* Interchange rows K and IPIV(K).
406*
407 kp = ipiv( k )
408 IF( kp.NE.k )
409 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
410 k = k - 1
411 ELSE
412*
413* 2 x 2 diagonal block
414*
415* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
416* stored in columns K-1 and K of A.
417*
418 IF( k.LT.n ) THEN
419 CALL cgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
420 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
421 CALL cgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
422 $ ldb, a( k+1, k-1 ), 1, one, b( k-1, 1 ),
423 $ ldb )
424 END IF
425*
426* Interchange rows K and -IPIV(K).
427*
428 kp = -ipiv( k )
429 IF( kp.NE.k )
430 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
431 k = k - 2
432 END IF
433*
434 GO TO 90
435 100 CONTINUE
436 END IF
437*
438 RETURN
439*
440* End of CSYTRS
441*
cgeru
subroutine cgeru(m, n, alpha, x, incx, y, incy, a, lda)
CGERU
Definition cgeru.f:130

◆ csytrs2()

subroutine csytrs2 ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
integer info )

CSYTRS2

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

Purpose:
!>
!> CSYTRS2 solves a system of linear equations A*X = B with a complex
!> symmetric matrix A using the factorization A = U*D*U**T or
!> A = L*D*L**T computed by CSYTRF and converted by CSYCONV.
!>
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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF.
!>          Note that A is input / output. This might be counter-intuitive,
!>          and one may think that A is input only. A is input / output. This
!>          is because, at the start of the subroutine, we permute A in a
!>           form and then we permute A back to its original form at
!>          the end.
!>
[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 CSYTRF.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 130 of file csytrs2.f.

132*
133* -- LAPACK computational routine --
134* -- LAPACK is a software package provided by Univ. of Tennessee, --
135* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136*
137* .. Scalar Arguments ..
138 CHARACTER UPLO
139 INTEGER INFO, LDA, LDB, N, NRHS
140* ..
141* .. Array Arguments ..
142 INTEGER IPIV( * )
143 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 COMPLEX ONE
150 parameter( one = (1.0e+0,0.0e+0) )
151* ..
152* .. Local Scalars ..
153 LOGICAL UPPER
154 INTEGER I, IINFO, J, K, KP
155 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
156* ..
157* .. External Functions ..
158 LOGICAL LSAME
159 EXTERNAL lsame
160* ..
161* .. External Subroutines ..
162 EXTERNAL cscal, csyconv, cswap, ctrsm, xerbla
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC max
166* ..
167* .. Executable Statements ..
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( nrhs.LT.0 ) THEN
176 info = -3
177 ELSE IF( lda.LT.max( 1, n ) ) THEN
178 info = -5
179 ELSE IF( ldb.LT.max( 1, n ) ) THEN
180 info = -8
181 END IF
182 IF( info.NE.0 ) THEN
183 CALL xerbla( 'CSYTRS2', -info )
184 RETURN
185 END IF
186*
187* Quick return if possible
188*
189 IF( n.EQ.0 .OR. nrhs.EQ.0 )
190 $ RETURN
191*
192* Convert A
193*
194 CALL csyconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
195*
196 IF( upper ) THEN
197*
198* Solve A*X = B, where A = U*D*U**T.
199*
200* P**T * B
201 k=n
202 DO WHILE ( k .GE. 1 )
203 IF( ipiv( k ).GT.0 ) THEN
204* 1 x 1 diagonal block
205* Interchange rows K and IPIV(K).
206 kp = ipiv( k )
207 IF( kp.NE.k )
208 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
209 k=k-1
210 ELSE
211* 2 x 2 diagonal block
212* Interchange rows K-1 and -IPIV(K).
213 kp = -ipiv( k )
214 IF( kp.EQ.-ipiv( k-1 ) )
215 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
216 k=k-2
217 END IF
218 END DO
219*
220* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
221*
222 CALL ctrsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb)
223*
224* Compute D \ B -> B [ D \ (U \P**T * B) ]
225*
226 i=n
227 DO WHILE ( i .GE. 1 )
228 IF( ipiv(i) .GT. 0 ) THEN
229 CALL cscal( nrhs, one / a( i, i ), b( i, 1 ), ldb )
230 ELSEIF ( i .GT. 1) THEN
231 IF ( ipiv(i-1) .EQ. ipiv(i) ) THEN
232 akm1k = work(i)
233 akm1 = a( i-1, i-1 ) / akm1k
234 ak = a( i, i ) / akm1k
235 denom = akm1*ak - one
236 DO 15 j = 1, nrhs
237 bkm1 = b( i-1, j ) / akm1k
238 bk = b( i, j ) / akm1k
239 b( i-1, j ) = ( ak*bkm1-bk ) / denom
240 b( i, j ) = ( akm1*bk-bkm1 ) / denom
241 15 CONTINUE
242 i = i - 1
243 ENDIF
244 ENDIF
245 i = i - 1
246 END DO
247*
248* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ]
249*
250 CALL ctrsm('L','U','T','U',n,nrhs,one,a,lda,b,ldb)
251*
252* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ]
253*
254 k=1
255 DO WHILE ( k .LE. n )
256 IF( ipiv( k ).GT.0 ) THEN
257* 1 x 1 diagonal block
258* Interchange rows K and IPIV(K).
259 kp = ipiv( k )
260 IF( kp.NE.k )
261 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
262 k=k+1
263 ELSE
264* 2 x 2 diagonal block
265* Interchange rows K-1 and -IPIV(K).
266 kp = -ipiv( k )
267 IF( k .LT. n .AND. kp.EQ.-ipiv( k+1 ) )
268 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
269 k=k+2
270 ENDIF
271 END DO
272*
273 ELSE
274*
275* Solve A*X = B, where A = L*D*L**T.
276*
277* P**T * B
278 k=1
279 DO WHILE ( k .LE. n )
280 IF( ipiv( k ).GT.0 ) THEN
281* 1 x 1 diagonal block
282* Interchange rows K and IPIV(K).
283 kp = ipiv( k )
284 IF( kp.NE.k )
285 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
286 k=k+1
287 ELSE
288* 2 x 2 diagonal block
289* Interchange rows K and -IPIV(K+1).
290 kp = -ipiv( k+1 )
291 IF( kp.EQ.-ipiv( k ) )
292 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
293 k=k+2
294 ENDIF
295 END DO
296*
297* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
298*
299 CALL ctrsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb)
300*
301* Compute D \ B -> B [ D \ (L \P**T * B) ]
302*
303 i=1
304 DO WHILE ( i .LE. n )
305 IF( ipiv(i) .GT. 0 ) THEN
306 CALL cscal( nrhs, one / a( i, i ), b( i, 1 ), ldb )
307 ELSE
308 akm1k = work(i)
309 akm1 = a( i, i ) / akm1k
310 ak = a( i+1, i+1 ) / akm1k
311 denom = akm1*ak - one
312 DO 25 j = 1, nrhs
313 bkm1 = b( i, j ) / akm1k
314 bk = b( i+1, j ) / akm1k
315 b( i, j ) = ( ak*bkm1-bk ) / denom
316 b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
317 25 CONTINUE
318 i = i + 1
319 ENDIF
320 i = i + 1
321 END DO
322*
323* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ]
324*
325 CALL ctrsm('L','L','T','U',n,nrhs,one,a,lda,b,ldb)
326*
327* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ]
328*
329 k=n
330 DO WHILE ( k .GE. 1 )
331 IF( ipiv( k ).GT.0 ) THEN
332* 1 x 1 diagonal block
333* Interchange rows K and IPIV(K).
334 kp = ipiv( k )
335 IF( kp.NE.k )
336 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
337 k=k-1
338 ELSE
339* 2 x 2 diagonal block
340* Interchange rows K-1 and -IPIV(K).
341 kp = -ipiv( k )
342 IF( k.GT.1 .AND. kp.EQ.-ipiv( k-1 ) )
343 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
344 k=k-2
345 ENDIF
346 END DO
347*
348 END IF
349*
350* Revert A
351*
352 CALL csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
353*
354 RETURN
355*
356* End of CSYTRS2
357*

◆ csytrs_3()

subroutine csytrs_3 ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
integer info )

CSYTRS_3

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

Purpose:
!> CSYTRS_3 solves a system of linear equations A * X = B with a complex
!> symmetric matrix A using the factorization computed
!> by CSYTRF_RK or CSYTRF_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 algorithm is using 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 triangular, form is A = P*U*D*(U**T)*(P**T);
!>          = 'L':  Lower triangular, form is A = P*L*D*(L**T)*(P**T).
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by CSYTRF_RK and CSYTRF_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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]E
!>          E is COMPLEX 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 referenced;
!>          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 CSYTRF_RK or CSYTRF_BK.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>  June 2017,  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 163 of file csytrs_3.f.

165*
166* -- LAPACK computational routine --
167* -- LAPACK is a software package provided by Univ. of Tennessee, --
168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169*
170* .. Scalar Arguments ..
171 CHARACTER UPLO
172 INTEGER INFO, LDA, LDB, N, NRHS
173* ..
174* .. Array Arguments ..
175 INTEGER IPIV( * )
176 COMPLEX A( LDA, * ), B( LDB, * ), E( * )
177* ..
178*
179* =====================================================================
180*
181* .. Parameters ..
182 COMPLEX ONE
183 parameter( one = ( 1.0e+0,0.0e+0 ) )
184* ..
185* .. Local Scalars ..
186 LOGICAL UPPER
187 INTEGER I, J, K, KP
188 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
189* ..
190* .. External Functions ..
191 LOGICAL LSAME
192 EXTERNAL lsame
193* ..
194* .. External Subroutines ..
195 EXTERNAL cscal, cswap, ctrsm, xerbla
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC abs, max
199* ..
200* .. Executable Statements ..
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( nrhs.LT.0 ) THEN
209 info = -3
210 ELSE IF( lda.LT.max( 1, n ) ) THEN
211 info = -5
212 ELSE IF( ldb.LT.max( 1, n ) ) THEN
213 info = -9
214 END IF
215 IF( info.NE.0 ) THEN
216 CALL xerbla( 'CSYTRS_3', -info )
217 RETURN
218 END IF
219*
220* Quick return if possible
221*
222 IF( n.EQ.0 .OR. nrhs.EQ.0 )
223 $ RETURN
224*
225 IF( upper ) THEN
226*
227* Begin Upper
228*
229* Solve A*X = B, where A = U*D*U**T.
230*
231* P**T * B
232*
233* Interchange rows K and IPIV(K) of matrix B in the same order
234* that the formation order of IPIV(I) vector for Upper case.
235*
236* (We can do the simple loop over IPIV with decrement -1,
237* since the ABS value of IPIV(I) represents the row index
238* of the interchange with row i in both 1x1 and 2x2 pivot cases)
239*
240 DO k = n, 1, -1
241 kp = abs( ipiv( k ) )
242 IF( kp.NE.k ) THEN
243 CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
244 END IF
245 END DO
246*
247* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
248*
249 CALL ctrsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b, ldb )
250*
251* Compute D \ B -> B [ D \ (U \P**T * B) ]
252*
253 i = n
254 DO WHILE ( i.GE.1 )
255 IF( ipiv( i ).GT.0 ) THEN
256 CALL cscal( nrhs, one / a( i, i ), b( i, 1 ), ldb )
257 ELSE IF ( i.GT.1 ) THEN
258 akm1k = e( i )
259 akm1 = a( i-1, i-1 ) / akm1k
260 ak = a( i, i ) / akm1k
261 denom = akm1*ak - one
262 DO j = 1, nrhs
263 bkm1 = b( i-1, j ) / akm1k
264 bk = b( i, j ) / akm1k
265 b( i-1, j ) = ( ak*bkm1-bk ) / denom
266 b( i, j ) = ( akm1*bk-bkm1 ) / denom
267 END DO
268 i = i - 1
269 END IF
270 i = i - 1
271 END DO
272*
273* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ]
274*
275 CALL ctrsm( 'L', 'U', 'T', 'U', n, nrhs, one, a, lda, b, ldb )
276*
277* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ]
278*
279* Interchange rows K and IPIV(K) of matrix B in reverse order
280* from the formation order of IPIV(I) vector for Upper case.
281*
282* (We can do the simple loop over IPIV with increment 1,
283* since the ABS value of IPIV( I ) represents the row index
284* of the interchange with row i in both 1x1 and 2x2 pivot cases)
285*
286 DO k = 1, n, 1
287 kp = abs( ipiv( k ) )
288 IF( kp.NE.k ) THEN
289 CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
290 END IF
291 END DO
292*
293 ELSE
294*
295* Begin Lower
296*
297* Solve A*X = B, where A = L*D*L**T.
298*
299* P**T * B
300* Interchange rows K and IPIV(K) of matrix B in the same order
301* that the formation order of IPIV(I) vector for Lower case.
302*
303* (We can do the simple loop over IPIV with increment 1,
304* since the ABS value of IPIV(I) represents the row index
305* of the interchange with row i in both 1x1 and 2x2 pivot cases)
306*
307 DO k = 1, n, 1
308 kp = abs( ipiv( k ) )
309 IF( kp.NE.k ) THEN
310 CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
311 END IF
312 END DO
313*
314* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
315*
316 CALL ctrsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb )
317*
318* Compute D \ B -> B [ D \ (L \P**T * B) ]
319*
320 i = 1
321 DO WHILE ( i.LE.n )
322 IF( ipiv( i ).GT.0 ) THEN
323 CALL cscal( nrhs, one / a( i, i ), b( i, 1 ), ldb )
324 ELSE IF( i.LT.n ) THEN
325 akm1k = e( i )
326 akm1 = a( i, i ) / akm1k
327 ak = a( i+1, i+1 ) / akm1k
328 denom = akm1*ak - one
329 DO j = 1, nrhs
330 bkm1 = b( i, j ) / akm1k
331 bk = b( i+1, j ) / akm1k
332 b( i, j ) = ( ak*bkm1-bk ) / denom
333 b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
334 END DO
335 i = i + 1
336 END IF
337 i = i + 1
338 END DO
339*
340* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ]
341*
342 CALL ctrsm('L', 'L', 'T', 'U', n, nrhs, one, a, lda, b, ldb )
343*
344* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ]
345*
346* Interchange rows K and IPIV(K) of matrix B in reverse order
347* from the formation order of IPIV(I) vector for Lower case.
348*
349* (We can do the simple loop over IPIV with decrement -1,
350* since the ABS value of IPIV(I) represents the row index
351* of the interchange with row i in both 1x1 and 2x2 pivot cases)
352*
353 DO k = n, 1, -1
354 kp = abs( ipiv( k ) )
355 IF( kp.NE.k ) THEN
356 CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
357 END IF
358 END DO
359*
360* END Lower
361*
362 END IF
363*
364 RETURN
365*
366* End of CSYTRS_3
367*

◆ csytrs_aa()

subroutine csytrs_aa ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
integer lwork,
integer info )

CSYTRS_AA

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

Purpose:
!>
!> CSYTRS_AA solves a system of linear equations A*X = B with a complex
!> symmetric matrix A using the factorization A = U**T*T*U or
!> A = L*T*L**T computed by CSYTRF_AA.
!>
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**T*T*U;
!>          = 'L':  Lower triangular, form is A = L*T*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          Details of factors computed by CSYTRF_AA.
!>
[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 as computed by CSYTRF_AA.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,3*N-2).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file csytrs_aa.f.

131*
132* -- LAPACK computational routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136 IMPLICIT NONE
137*
138* .. Scalar Arguments ..
139 CHARACTER UPLO
140 INTEGER N, NRHS, LDA, LDB, LWORK, INFO
141* ..
142* .. Array Arguments ..
143 INTEGER IPIV( * )
144 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149 COMPLEX ONE
150 parameter( one = 1.0e+0 )
151* ..
152* .. Local Scalars ..
153 LOGICAL LQUERY, UPPER
154 INTEGER K, KP, LWKOPT
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL clacpy, cgtsv, cswap, ctrsm, xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC max
165* ..
166* .. Executable Statements ..
167*
168 info = 0
169 upper = lsame( uplo, 'U' )
170 lquery = ( lwork.EQ.-1 )
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( nrhs.LT.0 ) THEN
176 info = -3
177 ELSE IF( lda.LT.max( 1, n ) ) THEN
178 info = -5
179 ELSE IF( ldb.LT.max( 1, n ) ) THEN
180 info = -8
181 ELSE IF( lwork.LT.max( 1, 3*n-2 ) .AND. .NOT.lquery ) THEN
182 info = -10
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'CSYTRS_AA', -info )
186 RETURN
187 ELSE IF( lquery ) THEN
188 lwkopt = (3*n-2)
189 work( 1 ) = lwkopt
190 RETURN
191 END IF
192*
193* Quick return if possible
194*
195 IF( n.EQ.0 .OR. nrhs.EQ.0 )
196 $ RETURN
197*
198 IF( upper ) THEN
199*
200* Solve A*X = B, where A = U**T*T*U.
201*
202* 1) Forward substitution with U**T
203*
204 IF( n.GT.1 ) THEN
205*
206* Pivot, P**T * B -> B
207*
208 DO k = 1, n
209 kp = ipiv( k )
210 IF( kp.NE.k )
211 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
212 END DO
213*
214* Compute U**T \ B -> B [ (U**T \P**T * B) ]
215*
216 CALL ctrsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),
217 $ lda, b( 2, 1 ), ldb)
218 END IF
219*
220* 2) Solve with triangular matrix T
221*
222* Compute T \ B -> B [ T \ (U**T \P**T * B) ]
223*
224 CALL clacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1)
225 IF( n.GT.1 ) THEN
226 CALL clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 )
227 CALL clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 )
228 END IF
229 CALL cgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,
230 $ info )
231*
232* 3) Backward substitution with U
233*
234 IF( n.GT.1 ) THEN
235*
236* Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ]
237*
238 CALL ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),
239 $ lda, b( 2, 1 ), ldb)
240*
241* Pivot, P * B -> B [ P * (U**T \ (T \ (U \P**T * B) )) ]
242*
243 DO k = n, 1, -1
244 kp = ipiv( k )
245 IF( kp.NE.k )
246 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
247 END DO
248 END IF
249*
250 ELSE
251*
252* Solve A*X = B, where A = L*T*L**T.
253*
254* 1) Forward substitution with L
255*
256 IF( n.GT.1 ) THEN
257*
258* Pivot, P**T * B -> B
259*
260 DO k = 1, n
261 kp = ipiv( k )
262 IF( kp.NE.k )
263 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
264 END DO
265*
266* Compute L \ B -> B [ (L \P**T * B) ]
267*
268 CALL ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),
269 $ lda, b( 2, 1 ), ldb)
270 END IF
271*
272* 2) Solve with triangular matrix T
273*
274*
275* Compute T \ B -> B [ T \ (L \P**T * B) ]
276*
277 CALL clacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
278 IF( n.GT.1 ) THEN
279 CALL clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 )
280 CALL clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 )
281 END IF
282 CALL cgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,
283 $ info)
284*
285* 3) Backward substitution with L**T
286*
287 IF( n.GT.1 ) THEN
288*
289* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
290*
291 CALL ctrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),
292 $ lda, b( 2, 1 ), ldb)
293*
294* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
295*
296 DO k = n, 1, -1
297 kp = ipiv( k )
298 IF( kp.NE.k )
299 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
300 END DO
301 END IF
302*
303 END IF
304*
305 RETURN
306*
307* End of CSYTRS_AA
308*
cgtsv
subroutine cgtsv(n, nrhs, dl, d, du, b, ldb, info)
CGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition cgtsv.f:124

◆ csytrs_aa_2stage()

subroutine csytrs_aa_2stage ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
complex, dimension( ldb, * ) b,
integer ldb,
integer info )

CSYTRS_AA_2STAGE

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

Purpose:
!>
!> CSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a complex
!> symmetric matrix A using the factorization A = U**T*T*U or
!> A = L*T*L**T computed by CSYTRF_AA_2STAGE.
!>
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**T*T*U;
!>          = 'L':  Lower triangular, form is A = L*T*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          Details of factors computed by CSYTRF_AA_2STAGE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is COMPLEX array, dimension (LTB)
!>          Details of factors computed by CSYTRF_AA_2STAGE.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          CSYTRF_AA_2STAGE.
!>
[in]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          CSYTRF_AA_2STAGE.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file csytrs_aa_2stage.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144 IMPLICIT NONE
145*
146* .. Scalar Arguments ..
147 CHARACTER UPLO
148 INTEGER N, NRHS, LDA, LTB, LDB, INFO
149* ..
150* .. Array Arguments ..
151 INTEGER IPIV( * ), IPIV2( * )
152 COMPLEX A( LDA, * ), TB( * ), B( LDB, * )
153* ..
154*
155* =====================================================================
156*
157 COMPLEX ONE
158 parameter( one = ( 1.0e+0, 0.0e+0 ) )
159* ..
160* .. Local Scalars ..
161 INTEGER LDTB, NB
162 LOGICAL UPPER
163* ..
164* .. External Functions ..
165 LOGICAL LSAME
166 EXTERNAL lsame
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgbtrs, claswp, ctrsm, xerbla
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC max
173* ..
174* .. Executable Statements ..
175*
176 info = 0
177 upper = lsame( uplo, 'U' )
178 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
179 info = -1
180 ELSE IF( n.LT.0 ) THEN
181 info = -2
182 ELSE IF( nrhs.LT.0 ) THEN
183 info = -3
184 ELSE IF( lda.LT.max( 1, n ) ) THEN
185 info = -5
186 ELSE IF( ltb.LT.( 4*n ) ) THEN
187 info = -7
188 ELSE IF( ldb.LT.max( 1, n ) ) THEN
189 info = -11
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'CSYTRS_AA_2STAGE', -info )
193 RETURN
194 END IF
195*
196* Quick return if possible
197*
198 IF( n.EQ.0 .OR. nrhs.EQ.0 )
199 $ RETURN
200*
201* Read NB and compute LDTB
202*
203 nb = int( tb( 1 ) )
204 ldtb = ltb/n
205*
206 IF( upper ) THEN
207*
208* Solve A*X = B, where A = U**T*T*U.
209*
210 IF( n.GT.nb ) THEN
211*
212* Pivot, P**T * B -> B
213*
214 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
215*
216* Compute (U**T \ B) -> B [ (U**T \P**T * B) ]
217*
218 CALL ctrsm( 'L', 'U', 'T', 'U', n-nb, nrhs, one, a(1, nb+1),
219 $ lda, b(nb+1, 1), ldb)
220*
221 END IF
222*
223* Compute T \ B -> B [ T \ (U**T \P**T * B) ]
224*
225 CALL cgbtrs( 'N', n, nb, nb, nrhs, tb, ldtb, ipiv2, b, ldb,
226 $ info)
227 IF( n.GT.nb ) THEN
228*
229* Compute (U \ B) -> B [ U \ (T \ (U**T \P**T * B) ) ]
230*
231 CALL ctrsm( 'L', 'U', 'N', 'U', n-nb, nrhs, one, a(1, nb+1),
232 $ lda, b(nb+1, 1), ldb)
233*
234* Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ]
235*
236 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
237*
238 END IF
239*
240 ELSE
241*
242* Solve A*X = B, where A = L*T*L**T.
243*
244 IF( n.GT.nb ) THEN
245*
246* Pivot, P**T * B -> B
247*
248 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
249*
250* Compute (L \ B) -> B [ (L \P**T * B) ]
251*
252 CALL ctrsm( 'L', 'L', 'N', 'U', n-nb, nrhs, one, a(nb+1, 1),
253 $ lda, b(nb+1, 1), ldb)
254*
255 END IF
256*
257* Compute T \ B -> B [ T \ (L \P**T * B) ]
258*
259 CALL cgbtrs( 'N', n, nb, nb, nrhs, tb, ldtb, ipiv2, b, ldb,
260 $ info)
261 IF( n.GT.nb ) THEN
262*
263* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
264*
265 CALL ctrsm( 'L', 'L', 'T', 'U', n-nb, nrhs, one, a(nb+1, 1),
266 $ lda, b(nb+1, 1), ldb)
267*
268* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
269*
270 CALL claswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
271*
272 END IF
273 END IF
274*
275 RETURN
276*
277* End of CSYTRS_AA_2STAGE
278*

◆ csytrs_rook()

subroutine csytrs_rook ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
integer info )

CSYTRS_ROOK

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

Purpose:
!>
!> CSYTRS_ROOK solves a system of linear equations A*X = B with
!> a complex symmetric matrix A using the factorization A = U*D*U**T or
!> A = L*D*L**T computed by CSYTRF_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**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF_ROOK.
!>
[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 CSYTRF_ROOK.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!>   December 2016, 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 134 of file csytrs_rook.f.

136*
137* -- LAPACK computational routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 CHARACTER UPLO
143 INTEGER INFO, LDA, LDB, N, NRHS
144* ..
145* .. Array Arguments ..
146 INTEGER IPIV( * )
147 COMPLEX A( LDA, * ), B( LDB, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 COMPLEX CONE
154 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
155* ..
156* .. Local Scalars ..
157 LOGICAL UPPER
158 INTEGER J, K, KP
159 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 EXTERNAL lsame
164* ..
165* .. External Subroutines ..
166 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max
170* ..
171* .. Executable Statements ..
172*
173 info = 0
174 upper = lsame( uplo, 'U' )
175 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
176 info = -1
177 ELSE IF( n.LT.0 ) THEN
178 info = -2
179 ELSE IF( nrhs.LT.0 ) THEN
180 info = -3
181 ELSE IF( lda.LT.max( 1, n ) ) THEN
182 info = -5
183 ELSE IF( ldb.LT.max( 1, n ) ) THEN
184 info = -8
185 END IF
186 IF( info.NE.0 ) THEN
187 CALL xerbla( 'CSYTRS_ROOK', -info )
188 RETURN
189 END IF
190*
191* Quick return if possible
192*
193 IF( n.EQ.0 .OR. nrhs.EQ.0 )
194 $ RETURN
195*
196 IF( upper ) THEN
197*
198* Solve A*X = B, where A = U*D*U**T.
199*
200* First solve U*D*X = B, overwriting B with X.
201*
202* K is the main loop index, decreasing from N to 1 in steps of
203* 1 or 2, depending on the size of the diagonal blocks.
204*
205 k = n
206 10 CONTINUE
207*
208* If K < 1, exit from loop.
209*
210 IF( k.LT.1 )
211 $ GO TO 30
212*
213 IF( ipiv( k ).GT.0 ) THEN
214*
215* 1 x 1 diagonal block
216*
217* Interchange rows K and IPIV(K).
218*
219 kp = ipiv( k )
220 IF( kp.NE.k )
221 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
222*
223* Multiply by inv(U(K)), where U(K) is the transformation
224* stored in column K of A.
225*
226 CALL cgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,
227 $ b( 1, 1 ), ldb )
228*
229* Multiply by the inverse of the diagonal block.
230*
231 CALL cscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb )
232 k = k - 1
233 ELSE
234*
235* 2 x 2 diagonal block
236*
237* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
238*
239 kp = -ipiv( k )
240 IF( kp.NE.k )
241 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
242*
243 kp = -ipiv( k-1 )
244 IF( kp.NE.k-1 )
245 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
246*
247* Multiply by inv(U(K)), where U(K) is the transformation
248* stored in columns K-1 and K of A.
249*
250 IF( k.GT.2 ) THEN
251 CALL cgeru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),
252 $ ldb, b( 1, 1 ), ldb )
253 CALL cgeru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),
254 $ ldb, b( 1, 1 ), ldb )
255 END IF
256*
257* Multiply by the inverse of the diagonal block.
258*
259 akm1k = a( k-1, k )
260 akm1 = a( k-1, k-1 ) / akm1k
261 ak = a( k, k ) / akm1k
262 denom = akm1*ak - cone
263 DO 20 j = 1, nrhs
264 bkm1 = b( k-1, j ) / akm1k
265 bk = b( k, j ) / akm1k
266 b( k-1, j ) = ( ak*bkm1-bk ) / denom
267 b( k, j ) = ( akm1*bk-bkm1 ) / denom
268 20 CONTINUE
269 k = k - 2
270 END IF
271*
272 GO TO 10
273 30 CONTINUE
274*
275* Next solve U**T *X = B, overwriting B with X.
276*
277* K is the main loop index, increasing from 1 to N in steps of
278* 1 or 2, depending on the size of the diagonal blocks.
279*
280 k = 1
281 40 CONTINUE
282*
283* If K > N, exit from loop.
284*
285 IF( k.GT.n )
286 $ GO TO 50
287*
288 IF( ipiv( k ).GT.0 ) THEN
289*
290* 1 x 1 diagonal block
291*
292* Multiply by inv(U**T(K)), where U(K) is the transformation
293* stored in column K of A.
294*
295 IF( k.GT.1 )
296 $ CALL cgemv( 'Transpose', k-1, nrhs, -cone, b,
297 $ ldb, a( 1, k ), 1, cone, b( k, 1 ), ldb )
298*
299* Interchange rows K and IPIV(K).
300*
301 kp = ipiv( k )
302 IF( kp.NE.k )
303 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
304 k = k + 1
305 ELSE
306*
307* 2 x 2 diagonal block
308*
309* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
310* stored in columns K and K+1 of A.
311*
312 IF( k.GT.1 ) THEN
313 CALL cgemv( 'Transpose', k-1, nrhs, -cone, b,
314 $ ldb, a( 1, k ), 1, cone, b( k, 1 ), ldb )
315 CALL cgemv( 'Transpose', k-1, nrhs, -cone, b,
316 $ ldb, a( 1, k+1 ), 1, cone, b( k+1, 1 ), ldb )
317 END IF
318*
319* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1).
320*
321 kp = -ipiv( k )
322 IF( kp.NE.k )
323 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
324*
325 kp = -ipiv( k+1 )
326 IF( kp.NE.k+1 )
327 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
328*
329 k = k + 2
330 END IF
331*
332 GO TO 40
333 50 CONTINUE
334*
335 ELSE
336*
337* Solve A*X = B, where A = L*D*L**T.
338*
339* First solve L*D*X = B, overwriting B with X.
340*
341* K is the main loop index, increasing from 1 to N in steps of
342* 1 or 2, depending on the size of the diagonal blocks.
343*
344 k = 1
345 60 CONTINUE
346*
347* If K > N, exit from loop.
348*
349 IF( k.GT.n )
350 $ GO TO 80
351*
352 IF( ipiv( k ).GT.0 ) THEN
353*
354* 1 x 1 diagonal block
355*
356* Interchange rows K and IPIV(K).
357*
358 kp = ipiv( k )
359 IF( kp.NE.k )
360 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
361*
362* Multiply by inv(L(K)), where L(K) is the transformation
363* stored in column K of A.
364*
365 IF( k.LT.n )
366 $ CALL cgeru( n-k, nrhs, -cone, a( k+1, k ), 1, b( k, 1 ),
367 $ ldb, b( k+1, 1 ), ldb )
368*
369* Multiply by the inverse of the diagonal block.
370*
371 CALL cscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb )
372 k = k + 1
373 ELSE
374*
375* 2 x 2 diagonal block
376*
377* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1)
378*
379 kp = -ipiv( k )
380 IF( kp.NE.k )
381 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
382*
383 kp = -ipiv( k+1 )
384 IF( kp.NE.k+1 )
385 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
386*
387* Multiply by inv(L(K)), where L(K) is the transformation
388* stored in columns K and K+1 of A.
389*
390 IF( k.LT.n-1 ) THEN
391 CALL cgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1, b( k, 1 ),
392 $ ldb, b( k+2, 1 ), ldb )
393 CALL cgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1,
394 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
395 END IF
396*
397* Multiply by the inverse of the diagonal block.
398*
399 akm1k = a( k+1, k )
400 akm1 = a( k, k ) / akm1k
401 ak = a( k+1, k+1 ) / akm1k
402 denom = akm1*ak - cone
403 DO 70 j = 1, nrhs
404 bkm1 = b( k, j ) / akm1k
405 bk = b( k+1, j ) / akm1k
406 b( k, j ) = ( ak*bkm1-bk ) / denom
407 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
408 70 CONTINUE
409 k = k + 2
410 END IF
411*
412 GO TO 60
413 80 CONTINUE
414*
415* Next solve L**T *X = B, overwriting B with X.
416*
417* K is the main loop index, decreasing from N to 1 in steps of
418* 1 or 2, depending on the size of the diagonal blocks.
419*
420 k = n
421 90 CONTINUE
422*
423* If K < 1, exit from loop.
424*
425 IF( k.LT.1 )
426 $ GO TO 100
427*
428 IF( ipiv( k ).GT.0 ) THEN
429*
430* 1 x 1 diagonal block
431*
432* Multiply by inv(L**T(K)), where L(K) is the transformation
433* stored in column K of A.
434*
435 IF( k.LT.n )
436 $ CALL cgemv( 'Transpose', n-k, nrhs, -cone, b( k+1, 1 ),
437 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
438*
439* Interchange rows K and IPIV(K).
440*
441 kp = ipiv( k )
442 IF( kp.NE.k )
443 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
444 k = k - 1
445 ELSE
446*
447* 2 x 2 diagonal block
448*
449* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
450* stored in columns K-1 and K of A.
451*
452 IF( k.LT.n ) THEN
453 CALL cgemv( 'Transpose', n-k, nrhs, -cone, b( k+1, 1 ),
454 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
455 CALL cgemv( 'Transpose', n-k, nrhs, -cone, b( k+1, 1 ),
456 $ ldb, a( k+1, k-1 ), 1, cone, b( k-1, 1 ),
457 $ ldb )
458 END IF
459*
460* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1)
461*
462 kp = -ipiv( k )
463 IF( kp.NE.k )
464 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
465*
466 kp = -ipiv( k-1 )
467 IF( kp.NE.k-1 )
468 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
469*
470 k = k - 2
471 END IF
472*
473 GO TO 90
474 100 CONTINUE
475 END IF
476*
477 RETURN
478*
479* End of CSYTRS_ROOK
480*

◆ ctgsyl()

subroutine ctgsyl ( character trans,
integer ijob,
integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( ldd, * ) d,
integer ldd,
complex, dimension( lde, * ) e,
integer lde,
complex, dimension( ldf, * ) f,
integer ldf,
real scale,
real dif,
complex, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer info )

CTGSYL

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

Purpose:
!>
!> CTGSYL solves the generalized Sylvester equation:
!>
!>             A * R - L * B = scale * C            (1)
!>             D * R - L * E = scale * F
!>
!> where R and L are unknown m-by-n matrices, (A, D), (B, E) and
!> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
!> respectively, with complex entries. A, B, D and E are upper
!> triangular (i.e., (A,D) and (B,E) in generalized Schur form).
!>
!> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
!> is an output scaling factor chosen to avoid overflow.
!>
!> In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
!> is defined as
!>
!>        Z = [ kron(In, A)  -kron(B**H, Im) ]        (2)
!>            [ kron(In, D)  -kron(E**H, Im) ],
!>
!> Here Ix is the identity matrix of size x and X**H is the conjugate
!> transpose of X. Kron(X, Y) is the Kronecker product between the
!> matrices X and Y.
!>
!> If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b
!> is solved for, which is equivalent to solve for R and L in
!>
!>             A**H * R + D**H * L = scale * C           (3)
!>             R * B**H + L * E**H = scale * -F
!>
!> This case (TRANS = 'C') is used to compute an one-norm-based estimate
!> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
!> and (B,E), using CLACON.
!>
!> If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of
!> Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
!> reciprocal of the smallest singular value of Z.
!>
!> This is a level-3 BLAS algorithm.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': solve the generalized sylvester equation (1).
!>          = 'C': solve the  system (3).
!>
[in]IJOB
!>          IJOB is INTEGER
!>          Specifies what kind of functionality to be performed.
!>          =0: solve (1) only.
!>          =1: The functionality of 0 and 3.
!>          =2: The functionality of 0 and 4.
!>          =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
!>              (look ahead strategy is used).
!>          =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
!>              (CGECON on sub-systems is used).
!>          Not referenced if TRANS = 'C'.
!>
[in]M
!>          M is INTEGER
!>          The order of the matrices A and D, and the row dimension of
!>          the matrices C, F, R and L.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices B and E, and the column dimension
!>          of the matrices C, F, R and L.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA, M)
!>          The upper triangular matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1, M).
!>
[in]B
!>          B is COMPLEX array, dimension (LDB, N)
!>          The upper triangular matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1, N).
!>
[in,out]C
!>          C is COMPLEX array, dimension (LDC, N)
!>          On entry, C contains the right-hand-side of the first matrix
!>          equation in (1) or (3).
!>          On exit, if IJOB = 0, 1 or 2, C has been overwritten by
!>          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
!>          the solution achieved during the computation of the
!>          Dif-estimate.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1, M).
!>
[in]D
!>          D is COMPLEX array, dimension (LDD, M)
!>          The upper triangular matrix D.
!>
[in]LDD
!>          LDD is INTEGER
!>          The leading dimension of the array D. LDD >= max(1, M).
!>
[in]E
!>          E is COMPLEX array, dimension (LDE, N)
!>          The upper triangular matrix E.
!>
[in]LDE
!>          LDE is INTEGER
!>          The leading dimension of the array E. LDE >= max(1, N).
!>
[in,out]F
!>          F is COMPLEX array, dimension (LDF, N)
!>          On entry, F contains the right-hand-side of the second matrix
!>          equation in (1) or (3).
!>          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
!>          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
!>          the solution achieved during the computation of the
!>          Dif-estimate.
!>
[in]LDF
!>          LDF is INTEGER
!>          The leading dimension of the array F. LDF >= max(1, M).
!>
[out]DIF
!>          DIF is REAL
!>          On exit DIF is the reciprocal of a lower bound of the
!>          reciprocal of the Dif-function, i.e. DIF is an upper bound of
!>          Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
!>          IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
!>
[out]SCALE
!>          SCALE is REAL
!>          On exit SCALE is the scaling factor in (1) or (3).
!>          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
!>          to a slightly perturbed system but the input matrices A, B,
!>          D and E have not been changed. If SCALE = 0, R and L will
!>          hold the solutions to the homogeneous system with C = F = 0.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK > = 1.
!>          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (M+N+2)
!>
[out]INFO
!>          INFO is INTEGER
!>            =0: successful exit
!>            <0: If INFO = -i, the i-th argument had an illegal value.
!>            >0: (A, D) and (B, E) have common or very close
!>                eigenvalues.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden.
References:
[1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software for Solving the Generalized Sylvester Equation and Estimating the Separation between Regular Matrix Pairs, Report UMINF - 93.23, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, December 1993, Revised April 1994, Also as LAPACK Working Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.
[2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. Appl., 15(4):1045-1060, 1994.
[3] B. Kagstrom and L. Westin, Generalized Schur Methods with Condition Estimators for Solving the Generalized Sylvester Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.

Definition at line 292 of file ctgsyl.f.

295*
296* -- LAPACK computational routine --
297* -- LAPACK is a software package provided by Univ. of Tennessee, --
298* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
299*
300* .. Scalar Arguments ..
301 CHARACTER TRANS
302 INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
303 $ LWORK, M, N
304 REAL DIF, SCALE
305* ..
306* .. Array Arguments ..
307 INTEGER IWORK( * )
308 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
309 $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
310 $ WORK( * )
311* ..
312*
313* =====================================================================
314* Replaced various illegal calls to CCOPY by calls to CLASET.
315* Sven Hammarling, 1/5/02.
316*
317* .. Parameters ..
318 REAL ZERO, ONE
319 parameter( zero = 0.0e+0, one = 1.0e+0 )
320 COMPLEX CZERO
321 parameter( czero = (0.0e+0, 0.0e+0) )
322* ..
323* .. Local Scalars ..
324 LOGICAL LQUERY, NOTRAN
325 INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
326 $ LINFO, LWMIN, MB, NB, P, PQ, Q
327 REAL DSCALE, DSUM, SCALE2, SCALOC
328* ..
329* .. External Functions ..
330 LOGICAL LSAME
331 INTEGER ILAENV
332 EXTERNAL lsame, ilaenv
333* ..
334* .. External Subroutines ..
335 EXTERNAL cgemm, clacpy, claset, cscal, ctgsy2, xerbla
336* ..
337* .. Intrinsic Functions ..
338 INTRINSIC cmplx, max, real, sqrt
339* ..
340* .. Executable Statements ..
341*
342* Decode and test input parameters
343*
344 info = 0
345 notran = lsame( trans, 'N' )
346 lquery = ( lwork.EQ.-1 )
347*
348 IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
349 info = -1
350 ELSE IF( notran ) THEN
351 IF( ( ijob.LT.0 ) .OR. ( ijob.GT.4 ) ) THEN
352 info = -2
353 END IF
354 END IF
355 IF( info.EQ.0 ) THEN
356 IF( m.LE.0 ) THEN
357 info = -3
358 ELSE IF( n.LE.0 ) THEN
359 info = -4
360 ELSE IF( lda.LT.max( 1, m ) ) THEN
361 info = -6
362 ELSE IF( ldb.LT.max( 1, n ) ) THEN
363 info = -8
364 ELSE IF( ldc.LT.max( 1, m ) ) THEN
365 info = -10
366 ELSE IF( ldd.LT.max( 1, m ) ) THEN
367 info = -12
368 ELSE IF( lde.LT.max( 1, n ) ) THEN
369 info = -14
370 ELSE IF( ldf.LT.max( 1, m ) ) THEN
371 info = -16
372 END IF
373 END IF
374*
375 IF( info.EQ.0 ) THEN
376 IF( notran ) THEN
377 IF( ijob.EQ.1 .OR. ijob.EQ.2 ) THEN
378 lwmin = max( 1, 2*m*n )
379 ELSE
380 lwmin = 1
381 END IF
382 ELSE
383 lwmin = 1
384 END IF
385 work( 1 ) = lwmin
386*
387 IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
388 info = -20
389 END IF
390 END IF
391*
392 IF( info.NE.0 ) THEN
393 CALL xerbla( 'CTGSYL', -info )
394 RETURN
395 ELSE IF( lquery ) THEN
396 RETURN
397 END IF
398*
399* Quick return if possible
400*
401 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
402 scale = 1
403 IF( notran ) THEN
404 IF( ijob.NE.0 ) THEN
405 dif = 0
406 END IF
407 END IF
408 RETURN
409 END IF
410*
411* Determine optimal block sizes MB and NB
412*
413 mb = ilaenv( 2, 'CTGSYL', trans, m, n, -1, -1 )
414 nb = ilaenv( 5, 'CTGSYL', trans, m, n, -1, -1 )
415*
416 isolve = 1
417 ifunc = 0
418 IF( notran ) THEN
419 IF( ijob.GE.3 ) THEN
420 ifunc = ijob - 2
421 CALL claset( 'F', m, n, czero, czero, c, ldc )
422 CALL claset( 'F', m, n, czero, czero, f, ldf )
423 ELSE IF( ijob.GE.1 .AND. notran ) THEN
424 isolve = 2
425 END IF
426 END IF
427*
428 IF( ( mb.LE.1 .AND. nb.LE.1 ) .OR. ( mb.GE.m .AND. nb.GE.n ) )
429 $ THEN
430*
431* Use unblocked Level 2 solver
432*
433 DO 30 iround = 1, isolve
434*
435 scale = one
436 dscale = zero
437 dsum = one
438 pq = m*n
439 CALL ctgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,
440 $ ldd, e, lde, f, ldf, scale, dsum, dscale,
441 $ info )
442 IF( dscale.NE.zero ) THEN
443 IF( ijob.EQ.1 .OR. ijob.EQ.3 ) THEN
444 dif = sqrt( real( 2*m*n ) ) / ( dscale*sqrt( dsum ) )
445 ELSE
446 dif = sqrt( real( pq ) ) / ( dscale*sqrt( dsum ) )
447 END IF
448 END IF
449 IF( isolve.EQ.2 .AND. iround.EQ.1 ) THEN
450 IF( notran ) THEN
451 ifunc = ijob
452 END IF
453 scale2 = scale
454 CALL clacpy( 'F', m, n, c, ldc, work, m )
455 CALL clacpy( 'F', m, n, f, ldf, work( m*n+1 ), m )
456 CALL claset( 'F', m, n, czero, czero, c, ldc )
457 CALL claset( 'F', m, n, czero, czero, f, ldf )
458 ELSE IF( isolve.EQ.2 .AND. iround.EQ.2 ) THEN
459 CALL clacpy( 'F', m, n, work, m, c, ldc )
460 CALL clacpy( 'F', m, n, work( m*n+1 ), m, f, ldf )
461 scale = scale2
462 END IF
463 30 CONTINUE
464*
465 RETURN
466*
467 END IF
468*
469* Determine block structure of A
470*
471 p = 0
472 i = 1
473 40 CONTINUE
474 IF( i.GT.m )
475 $ GO TO 50
476 p = p + 1
477 iwork( p ) = i
478 i = i + mb
479 IF( i.GE.m )
480 $ GO TO 50
481 GO TO 40
482 50 CONTINUE
483 iwork( p+1 ) = m + 1
484 IF( iwork( p ).EQ.iwork( p+1 ) )
485 $ p = p - 1
486*
487* Determine block structure of B
488*
489 q = p + 1
490 j = 1
491 60 CONTINUE
492 IF( j.GT.n )
493 $ GO TO 70
494*
495 q = q + 1
496 iwork( q ) = j
497 j = j + nb
498 IF( j.GE.n )
499 $ GO TO 70
500 GO TO 60
501*
502 70 CONTINUE
503 iwork( q+1 ) = n + 1
504 IF( iwork( q ).EQ.iwork( q+1 ) )
505 $ q = q - 1
506*
507 IF( notran ) THEN
508 DO 150 iround = 1, isolve
509*
510* Solve (I, J) - subsystem
511* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
512* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
513* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
514*
515 pq = 0
516 scale = one
517 dscale = zero
518 dsum = one
519 DO 130 j = p + 2, q
520 js = iwork( j )
521 je = iwork( j+1 ) - 1
522 nb = je - js + 1
523 DO 120 i = p, 1, -1
524 is = iwork( i )
525 ie = iwork( i+1 ) - 1
526 mb = ie - is + 1
527 CALL ctgsy2( trans, ifunc, mb, nb, a( is, is ), lda,
528 $ b( js, js ), ldb, c( is, js ), ldc,
529 $ d( is, is ), ldd, e( js, js ), lde,
530 $ f( is, js ), ldf, scaloc, dsum, dscale,
531 $ linfo )
532 IF( linfo.GT.0 )
533 $ info = linfo
534 pq = pq + mb*nb
535 IF( scaloc.NE.one ) THEN
536 DO 80 k = 1, js - 1
537 CALL cscal( m, cmplx( scaloc, zero ), c( 1, k ),
538 $ 1 )
539 CALL cscal( m, cmplx( scaloc, zero ), f( 1, k ),
540 $ 1 )
541 80 CONTINUE
542 DO 90 k = js, je
543 CALL cscal( is-1, cmplx( scaloc, zero ),
544 $ c( 1, k ), 1 )
545 CALL cscal( is-1, cmplx( scaloc, zero ),
546 $ f( 1, k ), 1 )
547 90 CONTINUE
548 DO 100 k = js, je
549 CALL cscal( m-ie, cmplx( scaloc, zero ),
550 $ c( ie+1, k ), 1 )
551 CALL cscal( m-ie, cmplx( scaloc, zero ),
552 $ f( ie+1, k ), 1 )
553 100 CONTINUE
554 DO 110 k = je + 1, n
555 CALL cscal( m, cmplx( scaloc, zero ), c( 1, k ),
556 $ 1 )
557 CALL cscal( m, cmplx( scaloc, zero ), f( 1, k ),
558 $ 1 )
559 110 CONTINUE
560 scale = scale*scaloc
561 END IF
562*
563* Substitute R(I,J) and L(I,J) into remaining equation.
564*
565 IF( i.GT.1 ) THEN
566 CALL cgemm( 'N', 'N', is-1, nb, mb,
567 $ cmplx( -one, zero ), a( 1, is ), lda,
568 $ c( is, js ), ldc, cmplx( one, zero ),
569 $ c( 1, js ), ldc )
570 CALL cgemm( 'N', 'N', is-1, nb, mb,
571 $ cmplx( -one, zero ), d( 1, is ), ldd,
572 $ c( is, js ), ldc, cmplx( one, zero ),
573 $ f( 1, js ), ldf )
574 END IF
575 IF( j.LT.q ) THEN
576 CALL cgemm( 'N', 'N', mb, n-je, nb,
577 $ cmplx( one, zero ), f( is, js ), ldf,
578 $ b( js, je+1 ), ldb, cmplx( one, zero ),
579 $ c( is, je+1 ), ldc )
580 CALL cgemm( 'N', 'N', mb, n-je, nb,
581 $ cmplx( one, zero ), f( is, js ), ldf,
582 $ e( js, je+1 ), lde, cmplx( one, zero ),
583 $ f( is, je+1 ), ldf )
584 END IF
585 120 CONTINUE
586 130 CONTINUE
587 IF( dscale.NE.zero ) THEN
588 IF( ijob.EQ.1 .OR. ijob.EQ.3 ) THEN
589 dif = sqrt( real( 2*m*n ) ) / ( dscale*sqrt( dsum ) )
590 ELSE
591 dif = sqrt( real( pq ) ) / ( dscale*sqrt( dsum ) )
592 END IF
593 END IF
594 IF( isolve.EQ.2 .AND. iround.EQ.1 ) THEN
595 IF( notran ) THEN
596 ifunc = ijob
597 END IF
598 scale2 = scale
599 CALL clacpy( 'F', m, n, c, ldc, work, m )
600 CALL clacpy( 'F', m, n, f, ldf, work( m*n+1 ), m )
601 CALL claset( 'F', m, n, czero, czero, c, ldc )
602 CALL claset( 'F', m, n, czero, czero, f, ldf )
603 ELSE IF( isolve.EQ.2 .AND. iround.EQ.2 ) THEN
604 CALL clacpy( 'F', m, n, work, m, c, ldc )
605 CALL clacpy( 'F', m, n, work( m*n+1 ), m, f, ldf )
606 scale = scale2
607 END IF
608 150 CONTINUE
609 ELSE
610*
611* Solve transposed (I, J)-subsystem
612* A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J)
613* R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
614* for I = 1,2,..., P; J = Q, Q-1,..., 1
615*
616 scale = one
617 DO 210 i = 1, p
618 is = iwork( i )
619 ie = iwork( i+1 ) - 1
620 mb = ie - is + 1
621 DO 200 j = q, p + 2, -1
622 js = iwork( j )
623 je = iwork( j+1 ) - 1
624 nb = je - js + 1
625 CALL ctgsy2( trans, ifunc, mb, nb, a( is, is ), lda,
626 $ b( js, js ), ldb, c( is, js ), ldc,
627 $ d( is, is ), ldd, e( js, js ), lde,
628 $ f( is, js ), ldf, scaloc, dsum, dscale,
629 $ linfo )
630 IF( linfo.GT.0 )
631 $ info = linfo
632 IF( scaloc.NE.one ) THEN
633 DO 160 k = 1, js - 1
634 CALL cscal( m, cmplx( scaloc, zero ), c( 1, k ),
635 $ 1 )
636 CALL cscal( m, cmplx( scaloc, zero ), f( 1, k ),
637 $ 1 )
638 160 CONTINUE
639 DO 170 k = js, je
640 CALL cscal( is-1, cmplx( scaloc, zero ), c( 1, k ),
641 $ 1 )
642 CALL cscal( is-1, cmplx( scaloc, zero ), f( 1, k ),
643 $ 1 )
644 170 CONTINUE
645 DO 180 k = js, je
646 CALL cscal( m-ie, cmplx( scaloc, zero ),
647 $ c( ie+1, k ), 1 )
648 CALL cscal( m-ie, cmplx( scaloc, zero ),
649 $ f( ie+1, k ), 1 )
650 180 CONTINUE
651 DO 190 k = je + 1, n
652 CALL cscal( m, cmplx( scaloc, zero ), c( 1, k ),
653 $ 1 )
654 CALL cscal( m, cmplx( scaloc, zero ), f( 1, k ),
655 $ 1 )
656 190 CONTINUE
657 scale = scale*scaloc
658 END IF
659*
660* Substitute R(I,J) and L(I,J) into remaining equation.
661*
662 IF( j.GT.p+2 ) THEN
663 CALL cgemm( 'N', 'C', mb, js-1, nb,
664 $ cmplx( one, zero ), c( is, js ), ldc,
665 $ b( 1, js ), ldb, cmplx( one, zero ),
666 $ f( is, 1 ), ldf )
667 CALL cgemm( 'N', 'C', mb, js-1, nb,
668 $ cmplx( one, zero ), f( is, js ), ldf,
669 $ e( 1, js ), lde, cmplx( one, zero ),
670 $ f( is, 1 ), ldf )
671 END IF
672 IF( i.LT.p ) THEN
673 CALL cgemm( 'C', 'N', m-ie, nb, mb,
674 $ cmplx( -one, zero ), a( is, ie+1 ), lda,
675 $ c( is, js ), ldc, cmplx( one, zero ),
676 $ c( ie+1, js ), ldc )
677 CALL cgemm( 'C', 'N', m-ie, nb, mb,
678 $ cmplx( -one, zero ), d( is, ie+1 ), ldd,
679 $ f( is, js ), ldf, cmplx( one, zero ),
680 $ c( ie+1, js ), ldc )
681 END IF
682 200 CONTINUE
683 210 CONTINUE
684 END IF
685*
686 work( 1 ) = lwmin
687*
688 RETURN
689*
690* End of CTGSYL
691*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
ctgsy2
subroutine ctgsy2(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, rdsum, rdscal, info)
CTGSY2 solves the generalized Sylvester equation (unblocked algorithm).
Definition ctgsy2.f:259

◆ ctrsyl()

subroutine ctrsyl ( character trana,
character tranb,
integer isgn,
integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldc, * ) c,
integer ldc,
real scale,
integer info )

CTRSYL

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

Purpose:
!>
!> CTRSYL solves the complex Sylvester matrix equation:
!>
!>    op(A)*X + X*op(B) = scale*C or
!>    op(A)*X - X*op(B) = scale*C,
!>
!> where op(A) = A or A**H, and A and B are both upper triangular. A is
!> M-by-M and B is N-by-N; the right hand side C and the solution X are
!> M-by-N; and scale is an output scale factor, set <= 1 to avoid
!> overflow in X.
!>
Parameters
[in]TRANA
!>          TRANA is CHARACTER*1
!>          Specifies the option op(A):
!>          = 'N': op(A) = A    (No transpose)
!>          = 'C': op(A) = A**H (Conjugate transpose)
!>
[in]TRANB
!>          TRANB is CHARACTER*1
!>          Specifies the option op(B):
!>          = 'N': op(B) = B    (No transpose)
!>          = 'C': op(B) = B**H (Conjugate transpose)
!>
[in]ISGN
!>          ISGN is INTEGER
!>          Specifies the sign in the equation:
!>          = +1: solve op(A)*X + X*op(B) = scale*C
!>          = -1: solve op(A)*X - X*op(B) = scale*C
!>
[in]M
!>          M is INTEGER
!>          The order of the matrix A, and the number of rows in the
!>          matrices X and C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B, and the number of columns in the
!>          matrices X and C. N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,M)
!>          The upper triangular matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          The upper triangular matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[in,out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>          On entry, the M-by-N right hand side matrix C.
!>          On exit, C is overwritten by the solution matrix X.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M)
!>
[out]SCALE
!>          SCALE is REAL
!>          The scale factor, scale, set <= 1 to avoid overflow in X.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1: A and B have common or very close eigenvalues; perturbed
!>               values were used to solve the equation (but the matrices
!>               A and B are unchanged).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file ctrsyl.f.

157*
158* -- LAPACK computational routine --
159* -- LAPACK is a software package provided by Univ. of Tennessee, --
160* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161*
162* .. Scalar Arguments ..
163 CHARACTER TRANA, TRANB
164 INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
165 REAL SCALE
166* ..
167* .. Array Arguments ..
168 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE
175 parameter( one = 1.0e+0 )
176* ..
177* .. Local Scalars ..
178 LOGICAL NOTRNA, NOTRNB
179 INTEGER J, K, L
180 REAL BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
181 $ SMLNUM
182 COMPLEX A11, SUML, SUMR, VEC, X11
183* ..
184* .. Local Arrays ..
185 REAL DUM( 1 )
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 REAL CLANGE, SLAMCH
190 COMPLEX CDOTC, CDOTU, CLADIV
191 EXTERNAL lsame, clange, slamch, cdotc, cdotu, cladiv
192* ..
193* .. External Subroutines ..
194 EXTERNAL csscal, slabad, xerbla
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
198* ..
199* .. Executable Statements ..
200*
201* Decode and Test input parameters
202*
203 notrna = lsame( trana, 'N' )
204 notrnb = lsame( tranb, 'N' )
205*
206 info = 0
207 IF( .NOT.notrna .AND. .NOT.lsame( trana, 'C' ) ) THEN
208 info = -1
209 ELSE IF( .NOT.notrnb .AND. .NOT.lsame( tranb, 'C' ) ) THEN
210 info = -2
211 ELSE IF( isgn.NE.1 .AND. isgn.NE.-1 ) THEN
212 info = -3
213 ELSE IF( m.LT.0 ) THEN
214 info = -4
215 ELSE IF( n.LT.0 ) THEN
216 info = -5
217 ELSE IF( lda.LT.max( 1, m ) ) THEN
218 info = -7
219 ELSE IF( ldb.LT.max( 1, n ) ) THEN
220 info = -9
221 ELSE IF( ldc.LT.max( 1, m ) ) THEN
222 info = -11
223 END IF
224 IF( info.NE.0 ) THEN
225 CALL xerbla( 'CTRSYL', -info )
226 RETURN
227 END IF
228*
229* Quick return if possible
230*
231 scale = one
232 IF( m.EQ.0 .OR. n.EQ.0 )
233 $ RETURN
234*
235* Set constants to control overflow
236*
237 eps = slamch( 'P' )
238 smlnum = slamch( 'S' )
239 bignum = one / smlnum
240 CALL slabad( smlnum, bignum )
241 smlnum = smlnum*real( m*n ) / eps
242 bignum = one / smlnum
243 smin = max( smlnum, eps*clange( 'M', m, m, a, lda, dum ),
244 $ eps*clange( 'M', n, n, b, ldb, dum ) )
245 sgn = isgn
246*
247 IF( notrna .AND. notrnb ) THEN
248*
249* Solve A*X + ISGN*X*B = scale*C.
250*
251* The (K,L)th block of X is determined starting from
252* bottom-left corner column by column by
253*
254* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
255*
256* Where
257* M L-1
258* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
259* I=K+1 J=1
260*
261 DO 30 l = 1, n
262 DO 20 k = m, 1, -1
263*
264 suml = cdotu( m-k, a( k, min( k+1, m ) ), lda,
265 $ c( min( k+1, m ), l ), 1 )
266 sumr = cdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
267 vec = c( k, l ) - ( suml+sgn*sumr )
268*
269 scaloc = one
270 a11 = a( k, k ) + sgn*b( l, l )
271 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
272 IF( da11.LE.smin ) THEN
273 a11 = smin
274 da11 = smin
275 info = 1
276 END IF
277 db = abs( real( vec ) ) + abs( aimag( vec ) )
278 IF( da11.LT.one .AND. db.GT.one ) THEN
279 IF( db.GT.bignum*da11 )
280 $ scaloc = one / db
281 END IF
282 x11 = cladiv( vec*cmplx( scaloc ), a11 )
283*
284 IF( scaloc.NE.one ) THEN
285 DO 10 j = 1, n
286 CALL csscal( m, scaloc, c( 1, j ), 1 )
287 10 CONTINUE
288 scale = scale*scaloc
289 END IF
290 c( k, l ) = x11
291*
292 20 CONTINUE
293 30 CONTINUE
294*
295 ELSE IF( .NOT.notrna .AND. notrnb ) THEN
296*
297* Solve A**H *X + ISGN*X*B = scale*C.
298*
299* The (K,L)th block of X is determined starting from
300* upper-left corner column by column by
301*
302* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
303*
304* Where
305* K-1 L-1
306* R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
307* I=1 J=1
308*
309 DO 60 l = 1, n
310 DO 50 k = 1, m
311*
312 suml = cdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
313 sumr = cdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
314 vec = c( k, l ) - ( suml+sgn*sumr )
315*
316 scaloc = one
317 a11 = conjg( a( k, k ) ) + sgn*b( l, l )
318 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
319 IF( da11.LE.smin ) THEN
320 a11 = smin
321 da11 = smin
322 info = 1
323 END IF
324 db = abs( real( vec ) ) + abs( aimag( vec ) )
325 IF( da11.LT.one .AND. db.GT.one ) THEN
326 IF( db.GT.bignum*da11 )
327 $ scaloc = one / db
328 END IF
329*
330 x11 = cladiv( vec*cmplx( scaloc ), a11 )
331*
332 IF( scaloc.NE.one ) THEN
333 DO 40 j = 1, n
334 CALL csscal( m, scaloc, c( 1, j ), 1 )
335 40 CONTINUE
336 scale = scale*scaloc
337 END IF
338 c( k, l ) = x11
339*
340 50 CONTINUE
341 60 CONTINUE
342*
343 ELSE IF( .NOT.notrna .AND. .NOT.notrnb ) THEN
344*
345* Solve A**H*X + ISGN*X*B**H = C.
346*
347* The (K,L)th block of X is determined starting from
348* upper-right corner column by column by
349*
350* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
351*
352* Where
353* K-1
354* R(K,L) = SUM [A**H(I,K)*X(I,L)] +
355* I=1
356* N
357* ISGN*SUM [X(K,J)*B**H(L,J)].
358* J=L+1
359*
360 DO 90 l = n, 1, -1
361 DO 80 k = 1, m
362*
363 suml = cdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
364 sumr = cdotc( n-l, c( k, min( l+1, n ) ), ldc,
365 $ b( l, min( l+1, n ) ), ldb )
366 vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
367*
368 scaloc = one
369 a11 = conjg( a( k, k )+sgn*b( l, l ) )
370 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
371 IF( da11.LE.smin ) THEN
372 a11 = smin
373 da11 = smin
374 info = 1
375 END IF
376 db = abs( real( vec ) ) + abs( aimag( vec ) )
377 IF( da11.LT.one .AND. db.GT.one ) THEN
378 IF( db.GT.bignum*da11 )
379 $ scaloc = one / db
380 END IF
381*
382 x11 = cladiv( vec*cmplx( scaloc ), a11 )
383*
384 IF( scaloc.NE.one ) THEN
385 DO 70 j = 1, n
386 CALL csscal( m, scaloc, c( 1, j ), 1 )
387 70 CONTINUE
388 scale = scale*scaloc
389 END IF
390 c( k, l ) = x11
391*
392 80 CONTINUE
393 90 CONTINUE
394*
395 ELSE IF( notrna .AND. .NOT.notrnb ) THEN
396*
397* Solve A*X + ISGN*X*B**H = C.
398*
399* The (K,L)th block of X is determined starting from
400* bottom-left corner column by column by
401*
402* A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
403*
404* Where
405* M N
406* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
407* I=K+1 J=L+1
408*
409 DO 120 l = n, 1, -1
410 DO 110 k = m, 1, -1
411*
412 suml = cdotu( m-k, a( k, min( k+1, m ) ), lda,
413 $ c( min( k+1, m ), l ), 1 )
414 sumr = cdotc( n-l, c( k, min( l+1, n ) ), ldc,
415 $ b( l, min( l+1, n ) ), ldb )
416 vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
417*
418 scaloc = one
419 a11 = a( k, k ) + sgn*conjg( b( l, l ) )
420 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
421 IF( da11.LE.smin ) THEN
422 a11 = smin
423 da11 = smin
424 info = 1
425 END IF
426 db = abs( real( vec ) ) + abs( aimag( vec ) )
427 IF( da11.LT.one .AND. db.GT.one ) THEN
428 IF( db.GT.bignum*da11 )
429 $ scaloc = one / db
430 END IF
431*
432 x11 = cladiv( vec*cmplx( scaloc ), a11 )
433*
434 IF( scaloc.NE.one ) THEN
435 DO 100 j = 1, n
436 CALL csscal( m, scaloc, c( 1, j ), 1 )
437 100 CONTINUE
438 scale = scale*scaloc
439 END IF
440 c( k, l ) = x11
441*
442 110 CONTINUE
443 120 CONTINUE
444*
445 END IF
446*
447 RETURN
448*
449* End of CTRSYL
450*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
clange
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clange.f:115
cladiv
complex function cladiv(x, y)
CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition cladiv.f:64
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
cdotc
complex function cdotc(n, cx, incx, cy, incy)
CDOTC
Definition cdotc.f:83