OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches

Functions

subroutine zhecon (uplo, n, a, lda, ipiv, anorm, rcond, work, info)
 ZHECON
subroutine zhecon_3 (uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
 ZHECON_3
subroutine zhecon_rook (uplo, n, a, lda, ipiv, anorm, rcond, work, info)
  ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
subroutine zheequb (uplo, n, a, lda, s, scond, amax, work, info)
 ZHEEQUB
subroutine zhegs2 (itype, uplo, n, a, lda, b, ldb, info)
 ZHEGS2 reduces a Hermitian definite generalized eigenproblem to standard form, using the factorization results obtained from cpotrf (unblocked algorithm).
subroutine zhegst (itype, uplo, n, a, lda, b, ldb, info)
 ZHEGST
subroutine zherfs (uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZHERFS
subroutine zherfsx (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)
 ZHERFSX
subroutine zhetd2 (uplo, n, a, lda, d, e, tau, info)
 ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm).
subroutine zhetf2 (uplo, n, a, lda, ipiv, info)
 ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm, calling Level 2 BLAS).
subroutine zhetf2_rk (uplo, n, a, lda, e, ipiv, info)
 ZHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
subroutine zhetf2_rook (uplo, n, a, lda, ipiv, info)
 ZHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
subroutine zhetrd (uplo, n, a, lda, d, e, tau, work, lwork, info)
 ZHETRD
subroutine zhetrd_2stage (vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
 ZHETRD_2STAGE
subroutine zhetrd_he2hb (uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
 ZHETRD_HE2HB
subroutine zhetrf (uplo, n, a, lda, ipiv, work, lwork, info)
 ZHETRF
subroutine zhetrf_aa (uplo, n, a, lda, ipiv, work, lwork, info)
 ZHETRF_AA
subroutine zhetrf_rk (uplo, n, a, lda, e, ipiv, work, lwork, info)
 ZHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
subroutine zhetrf_rook (uplo, n, a, lda, ipiv, work, lwork, info)
 ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
subroutine zhetri (uplo, n, a, lda, ipiv, work, info)
 ZHETRI
subroutine zhetri2 (uplo, n, a, lda, ipiv, work, lwork, info)
 ZHETRI2
subroutine zhetri2x (uplo, n, a, lda, ipiv, work, nb, info)
 ZHETRI2X
subroutine zhetri_3 (uplo, n, a, lda, e, ipiv, work, lwork, info)
 ZHETRI_3
subroutine zhetri_3x (uplo, n, a, lda, e, ipiv, work, nb, info)
 ZHETRI_3X
subroutine zhetri_rook (uplo, n, a, lda, ipiv, work, info)
 ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
subroutine zhetrs (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZHETRS
subroutine zhetrs2 (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
 ZHETRS2
subroutine zhetrs_3 (uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
 ZHETRS_3
subroutine zhetrs_aa (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
 ZHETRS_AA
subroutine zhetrs_rook (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)
subroutine zla_heamv (uplo, n, alpha, a, lda, x, incx, beta, y, incy)
 ZLA_HEAMV computes a matrix-vector product using a Hermitian indefinite matrix to calculate error bounds.
double precision function zla_hercond_c (uplo, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
 ZLA_HERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian indefinite matrices.
double precision function zla_hercond_x (uplo, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
 ZLA_HERCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian indefinite matrices.
subroutine zla_herfsx_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)
 ZLA_HERFSX_EXTENDED improves the computed solution to a system of linear equations for Hermitian indefinite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.
double precision function zla_herpvgrw (uplo, n, info, a, lda, af, ldaf, ipiv, work)
 ZLA_HERPVGRW
subroutine zlahef (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
subroutine zlahef_aa (uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
 ZLAHEF_AA
subroutine zlahef_rk (uplo, n, nb, kb, a, lda, e, ipiv, w, ldw, info)
 ZLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
subroutine zlahef_rook (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
  Download ZLAHEF_ROOK + dependencies [TGZ] [ZIP] [TXT]

Detailed Description

This is the group of complex16 computational functions for HE matrices

Function Documentation

◆ zhecon()

subroutine zhecon ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
integer info )

ZHECON

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

Purpose:
!>
!> ZHECON estimates the reciprocal of the condition number of a complex
!> Hermitian matrix A using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by ZHETRF.
!>
!> 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**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> 
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHETRF.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHETRF.
!> 
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm of the original matrix A.
!> 
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          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*16 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 zhecon.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 DOUBLE PRECISION ANORM, RCOND
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 COMPLEX*16 A( LDA, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ONE, ZERO
144 parameter( one = 1.0d+0, zero = 0.0d+0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER I, KASE
149 DOUBLE PRECISION 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 xerbla, zhetrs, zlacn2
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( 'ZHECON', -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 zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
219 IF( kase.NE.0 ) THEN
220*
221* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
222*
223 CALL zhetrs( 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 ZHECON
235*
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
subroutine zhetrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZHETRS
Definition zhetrs.f:120
subroutine zlacn2(n, v, x, est, kase, isave)
ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition zlacn2.f:133
#define max(a, b)
Definition macros.h:21

◆ zhecon_3()

subroutine zhecon_3 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) e,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
integer info )

ZHECON_3

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

Purpose:
!> ZHECON_3 estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex Hermitian matrix A using the factorization
!> computed by ZHETRF_RK or ZHETRF_BK:
!>
!>    A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**H (or L**H) is the conjugate of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is Hermitian 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 ZHETRS_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**H)*(P**T);
!>          = 'L':  Lower triangular, form is A = P*L*D*(L**H)*(P**T).
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> 
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by ZHETRF_RK and ZHETRF_BK:
!>            a) ONLY diagonal elements of the Hermitian 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*16 array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian 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 ZHETRF_RK or ZHETRF_BK.
!> 
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm of the original matrix A.
!> 
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          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*16 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 zhecon_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 DOUBLE PRECISION ANORM, RCOND
175* ..
176* .. Array Arguments ..
177 INTEGER IPIV( * )
178 COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* .. Parameters ..
184 DOUBLE PRECISION ONE, ZERO
185 parameter( one = 1.0d+0, zero = 0.0d+0 )
186* ..
187* .. Local Scalars ..
188 LOGICAL UPPER
189 INTEGER I, KASE
190 DOUBLE PRECISION AINVNM
191* ..
192* .. Local Arrays ..
193 INTEGER ISAVE( 3 )
194* ..
195* .. External Functions ..
196 LOGICAL LSAME
197 EXTERNAL lsame
198* ..
199* .. External Subroutines ..
200 EXTERNAL zhetrs_3, zlacn2, xerbla
201* ..
202* .. Intrinsic Functions ..
203 INTRINSIC max
204* ..
205* .. Executable Statements ..
206*
207* Test the input parameters.
208*
209 info = 0
210 upper = lsame( uplo, 'U' )
211 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
212 info = -1
213 ELSE IF( n.LT.0 ) THEN
214 info = -2
215 ELSE IF( lda.LT.max( 1, n ) ) THEN
216 info = -4
217 ELSE IF( anorm.LT.zero ) THEN
218 info = -7
219 END IF
220 IF( info.NE.0 ) THEN
221 CALL xerbla( 'ZHECON_3', -info )
222 RETURN
223 END IF
224*
225* Quick return if possible
226*
227 rcond = zero
228 IF( n.EQ.0 ) THEN
229 rcond = one
230 RETURN
231 ELSE IF( anorm.LE.zero ) THEN
232 RETURN
233 END IF
234*
235* Check that the diagonal matrix D is nonsingular.
236*
237 IF( upper ) THEN
238*
239* Upper triangular storage: examine D from bottom to top
240*
241 DO i = n, 1, -1
242 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
243 $ RETURN
244 END DO
245 ELSE
246*
247* Lower triangular storage: examine D from top to bottom.
248*
249 DO i = 1, n
250 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
251 $ RETURN
252 END DO
253 END IF
254*
255* Estimate the 1-norm of the inverse.
256*
257 kase = 0
258 30 CONTINUE
259 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
260 IF( kase.NE.0 ) THEN
261*
262* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
263*
264 CALL zhetrs_3( uplo, n, 1, a, lda, e, ipiv, work, n, info )
265 GO TO 30
266 END IF
267*
268* Compute the estimate of the reciprocal condition number.
269*
270 IF( ainvnm.NE.zero )
271 $ rcond = ( one / ainvnm ) / anorm
272*
273 RETURN
274*
275* End of ZHECON_3
276*
subroutine zhetrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
ZHETRS_3
Definition zhetrs_3.f:165

◆ zhecon_rook()

subroutine zhecon_rook ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
integer info )

ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)

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

Purpose:
!>
!> ZHECON_ROOK estimates the reciprocal of the condition number of a complex
!> Hermitian matrix A using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by CHETRF_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**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> 
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CHETRF_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 CHETRF_ROOK.
!> 
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm of the original matrix A.
!> 
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          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*16 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 137 of file zhecon_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 DOUBLE PRECISION ANORM, RCOND
148* ..
149* .. Array Arguments ..
150 INTEGER IPIV( * )
151 COMPLEX*16 A( LDA, * ), WORK( * )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 DOUBLE PRECISION ONE, ZERO
158 parameter( one = 1.0d+0, zero = 0.0d+0 )
159* ..
160* .. Local Scalars ..
161 LOGICAL UPPER
162 INTEGER I, KASE
163 DOUBLE PRECISION AINVNM
164* ..
165* .. Local Arrays ..
166 INTEGER ISAVE( 3 )
167* ..
168* .. External Functions ..
169 LOGICAL LSAME
170 EXTERNAL lsame
171* ..
172* .. External Subroutines ..
173 EXTERNAL zhetrs_rook, zlacn2, xerbla
174* ..
175* .. Intrinsic Functions ..
176 INTRINSIC max
177* ..
178* .. Executable Statements ..
179*
180* Test the input parameters.
181*
182 info = 0
183 upper = lsame( uplo, 'U' )
184 IF( .NOT.upper .AND. .NOT.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 ELSE IF( anorm.LT.zero ) THEN
191 info = -6
192 END IF
193 IF( info.NE.0 ) THEN
194 CALL xerbla( 'ZHECON_ROOK', -info )
195 RETURN
196 END IF
197*
198* Quick return if possible
199*
200 rcond = zero
201 IF( n.EQ.0 ) THEN
202 rcond = one
203 RETURN
204 ELSE IF( anorm.LE.zero ) THEN
205 RETURN
206 END IF
207*
208* Check that the diagonal matrix D is nonsingular.
209*
210 IF( upper ) THEN
211*
212* Upper triangular storage: examine D from bottom to top
213*
214 DO 10 i = n, 1, -1
215 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
216 $ RETURN
217 10 CONTINUE
218 ELSE
219*
220* Lower triangular storage: examine D from top to bottom.
221*
222 DO 20 i = 1, n
223 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
224 $ RETURN
225 20 CONTINUE
226 END IF
227*
228* Estimate the 1-norm of the inverse.
229*
230 kase = 0
231 30 CONTINUE
232 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
233 IF( kase.NE.0 ) THEN
234*
235* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
236*
237 CALL zhetrs_rook( uplo, n, 1, a, lda, ipiv, work, n, info )
238 GO TO 30
239 END IF
240*
241* Compute the estimate of the reciprocal condition number.
242*
243 IF( ainvnm.NE.zero )
244 $ rcond = ( one / ainvnm ) / anorm
245*
246 RETURN
247*
248* End of ZHECON_ROOK
249*
subroutine zhetrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...

◆ zheequb()

subroutine zheequb ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) s,
double precision scond,
double precision amax,
complex*16, dimension( * ) work,
integer info )

ZHEEQUB

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

Purpose:
!>
!> ZHEEQUB computes row and column scalings intended to equilibrate a
!> Hermitian 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*16 array, dimension (LDA,N)
!>          The N-by-N Hermitian 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 DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!> 
[out]SCOND
!>          SCOND is DOUBLE PRECISION
!>          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 DOUBLE PRECISION
!>          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*16 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 zheequb.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 DOUBLE PRECISION AMAX, SCOND
140 CHARACTER UPLO
141* ..
142* .. Array Arguments ..
143 COMPLEX*16 A( LDA, * ), WORK( * )
144 DOUBLE PRECISION S( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 DOUBLE PRECISION ONE, ZERO
151 parameter( one = 1.0d0, zero = 0.0d0 )
152 INTEGER MAX_ITER
153 parameter( max_iter = 100 )
154* ..
155* .. Local Scalars ..
156 INTEGER I, J, ITER
157 DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE,
158 $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ
159 LOGICAL UP
160 COMPLEX*16 ZDUM
161* ..
162* .. External Functions ..
163 DOUBLE PRECISION DLAMCH
164 LOGICAL LSAME
165 EXTERNAL dlamch, lsame
166* ..
167* .. External Subroutines ..
168 EXTERNAL zlassq, xerbla
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, dble, dimag, int, log, max, min, sqrt
172* ..
173* .. Statement Functions ..
174 DOUBLE PRECISION CABS1
175* ..
176* .. Statement Function Definitions ..
177 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZHEEQUB', -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.0d0 / s( j )
234 END DO
235
236 tol = one / sqrt( 2.0d0 * n )
237
238 DO iter = 1, max_iter
239 scale = 0.0d0
240 sumsq = 0.0d0
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.0d0
265 DO i = 1, n
266 avg = avg + dble( s( i )*work( i ) )
267 END DO
268 avg = avg / n
269
270 std = 0.0d0
271 DO i = n+1, 2*n
272 work( i ) = s( i-n ) * work( i-n ) - avg
273 END DO
274 CALL zlassq( 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 = ( n-2 ) * ( dble( work( i ) ) - t*si )
284 c0 = -(t*si)*si + 2 * dble( 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 + dble( work( i ) ) ) * d / n
320 s( i ) = si
321 END DO
322 END DO
323
324 999 CONTINUE
325
326 smlnum = dlamch( 'SAFEMIN' )
327 bignum = one / smlnum
328 smin = bignum
329 smax = zero
330 t = one / sqrt( avg )
331 base = dlamch( '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*
subroutine zlassq(n, x, incx, scl, sumsq)
ZLASSQ updates a sum of squares represented in scaled form.
Definition zlassq.f90:137
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
#define min(a, b)
Definition macros.h:20

◆ zhegs2()

subroutine zhegs2 ( integer itype,
character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZHEGS2 reduces a Hermitian definite generalized eigenproblem to standard form, using the factorization results obtained from cpotrf (unblocked algorithm).

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

Purpose:
!>
!> ZHEGS2 reduces a complex Hermitian-definite generalized
!> eigenproblem to standard form.
!>
!> If ITYPE = 1, the problem is A*x = lambda*B*x,
!> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
!>
!> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
!> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H *A*L.
!>
!> B must have been previously factorized as U**H *U or L*L**H by ZPOTRF.
!> 
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
!>          = 2 or 3: compute U*A*U**H or L**H *A*L.
!> 
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored, and how B has been factorized.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!> 
[in,out]A
!>          A is COMPLEX*16 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, if INFO = 0, the transformed matrix, stored in the
!>          same format as A.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          The triangular factor from the Cholesky factorization of B,
!>          as returned by ZPOTRF.
!>          B is modified by the routine but restored on exit.
!> 
[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 127 of file zhegs2.f.

128*
129* -- LAPACK computational routine --
130* -- LAPACK is a software package provided by Univ. of Tennessee, --
131* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
132*
133* .. Scalar Arguments ..
134 CHARACTER UPLO
135 INTEGER INFO, ITYPE, LDA, LDB, N
136* ..
137* .. Array Arguments ..
138 COMPLEX*16 A( LDA, * ), B( LDB, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ONE, HALF
145 parameter( one = 1.0d+0, half = 0.5d+0 )
146 COMPLEX*16 CONE
147 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
148* ..
149* .. Local Scalars ..
150 LOGICAL UPPER
151 INTEGER K
152 DOUBLE PRECISION AKK, BKK
153 COMPLEX*16 CT
154* ..
155* .. External Subroutines ..
156 EXTERNAL xerbla, zaxpy, zdscal, zher2, zlacgv, ztrmv,
157 $ ztrsv
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 EXTERNAL lsame
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 upper = lsame( uplo, 'U' )
172 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
173 info = -1
174 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
175 info = -2
176 ELSE IF( n.LT.0 ) THEN
177 info = -3
178 ELSE IF( lda.LT.max( 1, n ) ) THEN
179 info = -5
180 ELSE IF( ldb.LT.max( 1, n ) ) THEN
181 info = -7
182 END IF
183 IF( info.NE.0 ) THEN
184 CALL xerbla( 'ZHEGS2', -info )
185 RETURN
186 END IF
187*
188 IF( itype.EQ.1 ) THEN
189 IF( upper ) THEN
190*
191* Compute inv(U**H)*A*inv(U)
192*
193 DO 10 k = 1, n
194*
195* Update the upper triangle of A(k:n,k:n)
196*
197 akk = dble( a( k, k ) )
198 bkk = dble( b( k, k ) )
199 akk = akk / bkk**2
200 a( k, k ) = akk
201 IF( k.LT.n ) THEN
202 CALL zdscal( n-k, one / bkk, a( k, k+1 ), lda )
203 ct = -half*akk
204 CALL zlacgv( n-k, a( k, k+1 ), lda )
205 CALL zlacgv( n-k, b( k, k+1 ), ldb )
206 CALL zaxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ),
207 $ lda )
208 CALL zher2( uplo, n-k, -cone, a( k, k+1 ), lda,
209 $ b( k, k+1 ), ldb, a( k+1, k+1 ), lda )
210 CALL zaxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ),
211 $ lda )
212 CALL zlacgv( n-k, b( k, k+1 ), ldb )
213 CALL ztrsv( uplo, 'Conjugate transpose', 'Non-unit',
214 $ n-k, b( k+1, k+1 ), ldb, a( k, k+1 ),
215 $ lda )
216 CALL zlacgv( n-k, a( k, k+1 ), lda )
217 END IF
218 10 CONTINUE
219 ELSE
220*
221* Compute inv(L)*A*inv(L**H)
222*
223 DO 20 k = 1, n
224*
225* Update the lower triangle of A(k:n,k:n)
226*
227 akk = dble( a( k, k ) )
228 bkk = dble( b( k, k ) )
229 akk = akk / bkk**2
230 a( k, k ) = akk
231 IF( k.LT.n ) THEN
232 CALL zdscal( n-k, one / bkk, a( k+1, k ), 1 )
233 ct = -half*akk
234 CALL zaxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 )
235 CALL zher2( uplo, n-k, -cone, a( k+1, k ), 1,
236 $ b( k+1, k ), 1, a( k+1, k+1 ), lda )
237 CALL zaxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 )
238 CALL ztrsv( uplo, 'No transpose', 'Non-unit', n-k,
239 $ b( k+1, k+1 ), ldb, a( k+1, k ), 1 )
240 END IF
241 20 CONTINUE
242 END IF
243 ELSE
244 IF( upper ) THEN
245*
246* Compute U*A*U**H
247*
248 DO 30 k = 1, n
249*
250* Update the upper triangle of A(1:k,1:k)
251*
252 akk = dble( a( k, k ) )
253 bkk = dble( b( k, k ) )
254 CALL ztrmv( uplo, 'No transpose', 'Non-unit', k-1, b,
255 $ ldb, a( 1, k ), 1 )
256 ct = half*akk
257 CALL zaxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 )
258 CALL zher2( uplo, k-1, cone, a( 1, k ), 1, b( 1, k ), 1,
259 $ a, lda )
260 CALL zaxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 )
261 CALL zdscal( k-1, bkk, a( 1, k ), 1 )
262 a( k, k ) = akk*bkk**2
263 30 CONTINUE
264 ELSE
265*
266* Compute L**H *A*L
267*
268 DO 40 k = 1, n
269*
270* Update the lower triangle of A(1:k,1:k)
271*
272 akk = dble( a( k, k ) )
273 bkk = dble( b( k, k ) )
274 CALL zlacgv( k-1, a( k, 1 ), lda )
275 CALL ztrmv( uplo, 'Conjugate transpose', 'Non-unit', k-1,
276 $ b, ldb, a( k, 1 ), lda )
277 ct = half*akk
278 CALL zlacgv( k-1, b( k, 1 ), ldb )
279 CALL zaxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda )
280 CALL zher2( uplo, k-1, cone, a( k, 1 ), lda, b( k, 1 ),
281 $ ldb, a, lda )
282 CALL zaxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda )
283 CALL zlacgv( k-1, b( k, 1 ), ldb )
284 CALL zdscal( k-1, bkk, a( k, 1 ), lda )
285 CALL zlacgv( k-1, a( k, 1 ), lda )
286 a( k, k ) = akk*bkk**2
287 40 CONTINUE
288 END IF
289 END IF
290 RETURN
291*
292* End of ZHEGS2
293*
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
Definition zlacgv.f:74
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
ZTRMV
Definition ztrmv.f:147
subroutine zher2(uplo, n, alpha, x, incx, y, incy, a, lda)
ZHER2
Definition zher2.f:150
subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
ZTRSV
Definition ztrsv.f:149

◆ zhegst()

subroutine zhegst ( integer itype,
character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZHEGST

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

Purpose:
!>
!> ZHEGST reduces a complex Hermitian-definite generalized
!> eigenproblem to standard form.
!>
!> If ITYPE = 1, the problem is A*x = lambda*B*x,
!> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
!>
!> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
!> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
!>
!> B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.
!> 
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
!>          = 2 or 3: compute U*A*U**H or L**H*A*L.
!> 
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored and B is factored as
!>                  U**H*U;
!>          = 'L':  Lower triangle of A is stored and B is factored as
!>                  L*L**H.
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!> 
[in,out]A
!>          A is COMPLEX*16 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, if INFO = 0, the transformed matrix, stored in the
!>          same format as A.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          The triangular factor from the Cholesky factorization of B,
!>          as returned by ZPOTRF.
!>          B is modified by the routine but restored on exit.
!> 
[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 127 of file zhegst.f.

128*
129* -- LAPACK computational routine --
130* -- LAPACK is a software package provided by Univ. of Tennessee, --
131* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
132*
133* .. Scalar Arguments ..
134 CHARACTER UPLO
135 INTEGER INFO, ITYPE, LDA, LDB, N
136* ..
137* .. Array Arguments ..
138 COMPLEX*16 A( LDA, * ), B( LDB, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ONE
145 parameter( one = 1.0d+0 )
146 COMPLEX*16 CONE, HALF
147 parameter( cone = ( 1.0d+0, 0.0d+0 ),
148 $ half = ( 0.5d+0, 0.0d+0 ) )
149* ..
150* .. Local Scalars ..
151 LOGICAL UPPER
152 INTEGER K, KB, NB
153* ..
154* .. External Subroutines ..
155 EXTERNAL xerbla, zhegs2, zhemm, zher2k, ztrmm, ztrsm
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC max, min
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 INTEGER ILAENV
163 EXTERNAL lsame, ilaenv
164* ..
165* .. Executable Statements ..
166*
167* Test the input parameters.
168*
169 info = 0
170 upper = lsame( uplo, 'U' )
171 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
172 info = -1
173 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
174 info = -2
175 ELSE IF( n.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 = -7
181 END IF
182 IF( info.NE.0 ) THEN
183 CALL xerbla( 'ZHEGST', -info )
184 RETURN
185 END IF
186*
187* Quick return if possible
188*
189 IF( n.EQ.0 )
190 $ RETURN
191*
192* Determine the block size for this environment.
193*
194 nb = ilaenv( 1, 'ZHEGST', uplo, n, -1, -1, -1 )
195*
196 IF( nb.LE.1 .OR. nb.GE.n ) THEN
197*
198* Use unblocked code
199*
200 CALL zhegs2( itype, uplo, n, a, lda, b, ldb, info )
201 ELSE
202*
203* Use blocked code
204*
205 IF( itype.EQ.1 ) THEN
206 IF( upper ) THEN
207*
208* Compute inv(U**H)*A*inv(U)
209*
210 DO 10 k = 1, n, nb
211 kb = min( n-k+1, nb )
212*
213* Update the upper triangle of A(k:n,k:n)
214*
215 CALL zhegs2( itype, uplo, kb, a( k, k ), lda,
216 $ b( k, k ), ldb, info )
217 IF( k+kb.LE.n ) THEN
218 CALL ztrsm( 'Left', uplo, 'Conjugate transpose',
219 $ 'Non-unit', kb, n-k-kb+1, cone,
220 $ b( k, k ), ldb, a( k, k+kb ), lda )
221 CALL zhemm( 'Left', uplo, kb, n-k-kb+1, -half,
222 $ a( k, k ), lda, b( k, k+kb ), ldb,
223 $ cone, a( k, k+kb ), lda )
224 CALL zher2k( uplo, 'Conjugate transpose', n-k-kb+1,
225 $ kb, -cone, a( k, k+kb ), lda,
226 $ b( k, k+kb ), ldb, one,
227 $ a( k+kb, k+kb ), lda )
228 CALL zhemm( 'Left', uplo, kb, n-k-kb+1, -half,
229 $ a( k, k ), lda, b( k, k+kb ), ldb,
230 $ cone, a( k, k+kb ), lda )
231 CALL ztrsm( 'Right', uplo, 'No transpose',
232 $ 'Non-unit', kb, n-k-kb+1, cone,
233 $ b( k+kb, k+kb ), ldb, a( k, k+kb ),
234 $ lda )
235 END IF
236 10 CONTINUE
237 ELSE
238*
239* Compute inv(L)*A*inv(L**H)
240*
241 DO 20 k = 1, n, nb
242 kb = min( n-k+1, nb )
243*
244* Update the lower triangle of A(k:n,k:n)
245*
246 CALL zhegs2( itype, uplo, kb, a( k, k ), lda,
247 $ b( k, k ), ldb, info )
248 IF( k+kb.LE.n ) THEN
249 CALL ztrsm( 'Right', uplo, 'Conjugate transpose',
250 $ 'Non-unit', n-k-kb+1, kb, cone,
251 $ b( k, k ), ldb, a( k+kb, k ), lda )
252 CALL zhemm( 'Right', uplo, n-k-kb+1, kb, -half,
253 $ a( k, k ), lda, b( k+kb, k ), ldb,
254 $ cone, a( k+kb, k ), lda )
255 CALL zher2k( uplo, 'No transpose', n-k-kb+1, kb,
256 $ -cone, a( k+kb, k ), lda,
257 $ b( k+kb, k ), ldb, one,
258 $ a( k+kb, k+kb ), lda )
259 CALL zhemm( 'Right', uplo, n-k-kb+1, kb, -half,
260 $ a( k, k ), lda, b( k+kb, k ), ldb,
261 $ cone, a( k+kb, k ), lda )
262 CALL ztrsm( 'Left', uplo, 'No transpose',
263 $ 'Non-unit', n-k-kb+1, kb, cone,
264 $ b( k+kb, k+kb ), ldb, a( k+kb, k ),
265 $ lda )
266 END IF
267 20 CONTINUE
268 END IF
269 ELSE
270 IF( upper ) THEN
271*
272* Compute U*A*U**H
273*
274 DO 30 k = 1, n, nb
275 kb = min( n-k+1, nb )
276*
277* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
278*
279 CALL ztrmm( 'Left', uplo, 'No transpose', 'Non-unit',
280 $ k-1, kb, cone, b, ldb, a( 1, k ), lda )
281 CALL zhemm( 'Right', uplo, k-1, kb, half, a( k, k ),
282 $ lda, b( 1, k ), ldb, cone, a( 1, k ),
283 $ lda )
284 CALL zher2k( uplo, 'No transpose', k-1, kb, cone,
285 $ a( 1, k ), lda, b( 1, k ), ldb, one, a,
286 $ lda )
287 CALL zhemm( 'Right', uplo, k-1, kb, half, a( k, k ),
288 $ lda, b( 1, k ), ldb, cone, a( 1, k ),
289 $ lda )
290 CALL ztrmm( 'Right', uplo, 'Conjugate transpose',
291 $ 'Non-unit', k-1, kb, cone, b( k, k ), ldb,
292 $ a( 1, k ), lda )
293 CALL zhegs2( itype, uplo, kb, a( k, k ), lda,
294 $ b( k, k ), ldb, info )
295 30 CONTINUE
296 ELSE
297*
298* Compute L**H*A*L
299*
300 DO 40 k = 1, n, nb
301 kb = min( n-k+1, nb )
302*
303* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
304*
305 CALL ztrmm( 'Right', uplo, 'No transpose', 'Non-unit',
306 $ kb, k-1, cone, b, ldb, a( k, 1 ), lda )
307 CALL zhemm( 'Left', uplo, kb, k-1, half, a( k, k ),
308 $ lda, b( k, 1 ), ldb, cone, a( k, 1 ),
309 $ lda )
310 CALL zher2k( uplo, 'Conjugate transpose', k-1, kb,
311 $ cone, a( k, 1 ), lda, b( k, 1 ), ldb,
312 $ one, a, lda )
313 CALL zhemm( 'Left', uplo, kb, k-1, half, a( k, k ),
314 $ lda, b( k, 1 ), ldb, cone, a( k, 1 ),
315 $ lda )
316 CALL ztrmm( 'Left', uplo, 'Conjugate transpose',
317 $ 'Non-unit', kb, k-1, cone, b( k, k ), ldb,
318 $ a( k, 1 ), lda )
319 CALL zhegs2( itype, uplo, kb, a( k, k ), lda,
320 $ b( k, k ), ldb, info )
321 40 CONTINUE
322 END IF
323 END IF
324 END IF
325 RETURN
326*
327* End of ZHEGST
328*
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
subroutine zhegs2(itype, uplo, n, a, lda, b, ldb, info)
ZHEGS2 reduces a Hermitian definite generalized eigenproblem to standard form, using the factorizatio...
Definition zhegs2.f:128
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177
subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZHEMM
Definition zhemm.f:191
subroutine zher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZHER2K
Definition zher2k.f:198
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180

◆ zherfs()

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

ZHERFS

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

Purpose:
!>
!> ZHERFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is Hermitian 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*16 array, dimension (LDA,N)
!>          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.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in]AF
!>          AF is COMPLEX*16 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**H or
!>          A = L*D*L**H as computed by ZHETRF.
!> 
[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 ZHETRF.
!> 
[in]B
!>          B is COMPLEX*16 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*16 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by ZHETRS.
!>          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 DOUBLE PRECISION 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 DOUBLE PRECISION 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*16 array, dimension (2*N)
!> 
[out]RWORK
!>          RWORK is DOUBLE PRECISION 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 zherfs.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 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
204 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
205 $ WORK( * ), X( LDX, * )
206* ..
207*
208* =====================================================================
209*
210* .. Parameters ..
211 INTEGER ITMAX
212 parameter( itmax = 5 )
213 DOUBLE PRECISION ZERO
214 parameter( zero = 0.0d+0 )
215 COMPLEX*16 ONE
216 parameter( one = ( 1.0d+0, 0.0d+0 ) )
217 DOUBLE PRECISION TWO
218 parameter( two = 2.0d+0 )
219 DOUBLE PRECISION THREE
220 parameter( three = 3.0d+0 )
221* ..
222* .. Local Scalars ..
223 LOGICAL UPPER
224 INTEGER COUNT, I, J, K, KASE, NZ
225 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
226 COMPLEX*16 ZDUM
227* ..
228* .. Local Arrays ..
229 INTEGER ISAVE( 3 )
230* ..
231* .. External Subroutines ..
232 EXTERNAL xerbla, zaxpy, zcopy, zhemv, zhetrs, zlacn2
233* ..
234* .. Intrinsic Functions ..
235 INTRINSIC abs, dble, dimag, max
236* ..
237* .. External Functions ..
238 LOGICAL LSAME
239 DOUBLE PRECISION DLAMCH
240 EXTERNAL lsame, dlamch
241* ..
242* .. Statement Functions ..
243 DOUBLE PRECISION CABS1
244* ..
245* .. Statement Function definitions ..
246 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZHERFS', -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 = dlamch( 'Epsilon' )
288 safmin = dlamch( '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 zcopy( n, b( 1, j ), 1, work, 1 )
305 CALL zhemv( 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 ) + abs( dble( 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 ) + abs( dble( 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 zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
367 CALL zaxpy( 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 ZLACN2 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 zlacn2( 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**H).
411*
412 CALL zhetrs( 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 zhetrs( 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 ZHERFS
442*
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
subroutine zhemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
ZHEMV
Definition zhemv.f:154

◆ zherfsx()

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

ZHERFSX

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

Purpose:
!>
!>    ZHERFSX improves the computed solution to a system of linear
!>    equations when the coefficient matrix is Hermitian 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*16 array, dimension (LDA,N)
!>     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.
!> 
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in]AF
!>          AF is COMPLEX*16 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**H or A =
!>     L*D*L**H as computed by ZHETRF.
!> 
[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 ZHETRF.
!> 
[in,out]S
!>          S is DOUBLE PRECISION 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*16 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*16 array, dimension (LDX,NRHS)
!>     On entry, the solution matrix X, as computed by ZHETRS.
!>     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 DOUBLE PRECISION
!>     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 DOUBLE PRECISION 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 DOUBLE PRECISION 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) * dlamch('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) * dlamch('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) * dlamch('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 DOUBLE PRECISION 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) * dlamch('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) * dlamch('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) * dlamch('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 DOUBLE PRECISION 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.0D+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*16 array, dimension (2*N)
!> 
[out]RWORK
!>          RWORK is DOUBLE PRECISION 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 397 of file zherfsx.f.

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

◆ zhetd2()

subroutine zhetd2 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( * ) tau,
integer info )

ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm).

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

Purpose:
!>
!> ZHETD2 reduces a complex Hermitian matrix A to real symmetric
!> tridiagonal form T by a unitary similarity transformation:
!> Q**H * A * Q = T.
!> 
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian 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*16 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, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the unitary
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the unitary matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!> 
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!> 
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> 
[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.
Further Details:
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n-1) . . . H(2) H(1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
!>  A(1:i-1,i+1), and tau in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(n-1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
!>  and tau in TAU(i).
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  d   e   v2  v3  v4 )              (  d                  )
!>    (      d   e   v3  v4 )              (  e   d              )
!>    (          d   e   v4 )              (  v1  e   d          )
!>    (              d   e  )              (  v1  v2  e   d      )
!>    (                  d  )              (  v1  v2  v3  e   d  )
!>
!>  where d and e denote diagonal and off-diagonal elements of T, and vi
!>  denotes an element of the vector defining H(i).
!> 

Definition at line 174 of file zhetd2.f.

175*
176* -- LAPACK computational routine --
177* -- LAPACK is a software package provided by Univ. of Tennessee, --
178* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179*
180* .. Scalar Arguments ..
181 CHARACTER UPLO
182 INTEGER INFO, LDA, N
183* ..
184* .. Array Arguments ..
185 DOUBLE PRECISION D( * ), E( * )
186 COMPLEX*16 A( LDA, * ), TAU( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 COMPLEX*16 ONE, ZERO, HALF
193 parameter( one = ( 1.0d+0, 0.0d+0 ),
194 $ zero = ( 0.0d+0, 0.0d+0 ),
195 $ half = ( 0.5d+0, 0.0d+0 ) )
196* ..
197* .. Local Scalars ..
198 LOGICAL UPPER
199 INTEGER I
200 COMPLEX*16 ALPHA, TAUI
201* ..
202* .. External Subroutines ..
203 EXTERNAL xerbla, zaxpy, zhemv, zher2, zlarfg
204* ..
205* .. External Functions ..
206 LOGICAL LSAME
207 COMPLEX*16 ZDOTC
208 EXTERNAL lsame, zdotc
209* ..
210* .. Intrinsic Functions ..
211 INTRINSIC dble, max, min
212* ..
213* .. Executable Statements ..
214*
215* Test the input parameters
216*
217 info = 0
218 upper = lsame( uplo, 'U')
219 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
220 info = -1
221 ELSE IF( n.LT.0 ) THEN
222 info = -2
223 ELSE IF( lda.LT.max( 1, n ) ) THEN
224 info = -4
225 END IF
226 IF( info.NE.0 ) THEN
227 CALL xerbla( 'ZHETD2', -info )
228 RETURN
229 END IF
230*
231* Quick return if possible
232*
233 IF( n.LE.0 )
234 $ RETURN
235*
236 IF( upper ) THEN
237*
238* Reduce the upper triangle of A
239*
240 a( n, n ) = dble( a( n, n ) )
241 DO 10 i = n - 1, 1, -1
242*
243* Generate elementary reflector H(i) = I - tau * v * v**H
244* to annihilate A(1:i-1,i+1)
245*
246 alpha = a( i, i+1 )
247 CALL zlarfg( i, alpha, a( 1, i+1 ), 1, taui )
248 e( i ) = dble( alpha )
249*
250 IF( taui.NE.zero ) THEN
251*
252* Apply H(i) from both sides to A(1:i,1:i)
253*
254 a( i, i+1 ) = one
255*
256* Compute x := tau * A * v storing x in TAU(1:i)
257*
258 CALL zhemv( uplo, i, taui, a, lda, a( 1, i+1 ), 1, zero,
259 $ tau, 1 )
260*
261* Compute w := x - 1/2 * tau * (x**H * v) * v
262*
263 alpha = -half*taui*zdotc( i, tau, 1, a( 1, i+1 ), 1 )
264 CALL zaxpy( i, alpha, a( 1, i+1 ), 1, tau, 1 )
265*
266* Apply the transformation as a rank-2 update:
267* A := A - v * w**H - w * v**H
268*
269 CALL zher2( uplo, i, -one, a( 1, i+1 ), 1, tau, 1, a,
270 $ lda )
271*
272 ELSE
273 a( i, i ) = dble( a( i, i ) )
274 END IF
275 a( i, i+1 ) = e( i )
276 d( i+1 ) = dble( a( i+1, i+1 ) )
277 tau( i ) = taui
278 10 CONTINUE
279 d( 1 ) = dble( a( 1, 1 ) )
280 ELSE
281*
282* Reduce the lower triangle of A
283*
284 a( 1, 1 ) = dble( a( 1, 1 ) )
285 DO 20 i = 1, n - 1
286*
287* Generate elementary reflector H(i) = I - tau * v * v**H
288* to annihilate A(i+2:n,i)
289*
290 alpha = a( i+1, i )
291 CALL zlarfg( n-i, alpha, a( min( i+2, n ), i ), 1, taui )
292 e( i ) = dble( alpha )
293*
294 IF( taui.NE.zero ) THEN
295*
296* Apply H(i) from both sides to A(i+1:n,i+1:n)
297*
298 a( i+1, i ) = one
299*
300* Compute x := tau * A * v storing y in TAU(i:n-1)
301*
302 CALL zhemv( uplo, n-i, taui, a( i+1, i+1 ), lda,
303 $ a( i+1, i ), 1, zero, tau( i ), 1 )
304*
305* Compute w := x - 1/2 * tau * (x**H * v) * v
306*
307 alpha = -half*taui*zdotc( n-i, tau( i ), 1, a( i+1, i ),
308 $ 1 )
309 CALL zaxpy( n-i, alpha, a( i+1, i ), 1, tau( i ), 1 )
310*
311* Apply the transformation as a rank-2 update:
312* A := A - v * w**H - w * v**H
313*
314 CALL zher2( uplo, n-i, -one, a( i+1, i ), 1, tau( i ), 1,
315 $ a( i+1, i+1 ), lda )
316*
317 ELSE
318 a( i+1, i+1 ) = dble( a( i+1, i+1 ) )
319 END IF
320 a( i+1, i ) = e( i )
321 d( i ) = dble( a( i, i ) )
322 tau( i ) = taui
323 20 CONTINUE
324 d( n ) = dble( a( n, n ) )
325 END IF
326*
327 RETURN
328*
329* End of ZHETD2
330*
#define alpha
Definition eval.h:35
subroutine zlarfg(n, alpha, x, incx, tau)
ZLARFG generates an elementary reflector (Householder matrix).
Definition zlarfg.f:106
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83

◆ zhetf2()

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

ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm, calling Level 2 BLAS).

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

Purpose:
!>
!> ZHETF2 computes the factorization of a complex Hermitian matrix A
!> using the Bunch-Kaufman diagonal pivoting method:
!>
!>    A = U*D*U**H  or  A = L*D*L**H
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, U**H is the conjugate transpose of U, and D is
!> Hermitian 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
!>          Hermitian 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*16 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, 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**H, 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**H, 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.210 and l.393
!>         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!>    by
!>         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
!>
!>  01-01-96 - Based on modifications by
!>    J. Lewis, Boeing Computer Services Company
!>    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!> 

Definition at line 190 of file zhetf2.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*16 A( LDA, * )
203* ..
204*
205* =====================================================================
206*
207* .. Parameters ..
208 DOUBLE PRECISION ZERO, ONE
209 parameter( zero = 0.0d+0, one = 1.0d+0 )
210 DOUBLE PRECISION EIGHT, SEVTEN
211 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
212* ..
213* .. Local Scalars ..
214 LOGICAL UPPER
215 INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
216 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
217 $ TT
218 COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, ZDUM
219* ..
220* .. External Functions ..
221 LOGICAL LSAME, DISNAN
222 INTEGER IZAMAX
223 DOUBLE PRECISION DLAPY2
224 EXTERNAL lsame, izamax, dlapy2, disnan
225* ..
226* .. External Subroutines ..
227 EXTERNAL xerbla, zdscal, zher, zswap
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, sqrt
231* ..
232* .. Statement Functions ..
233 DOUBLE PRECISION CABS1
234* ..
235* .. Statement Function definitions ..
236 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
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( 'ZHETF2', -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**H 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 90
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 = abs( dble( 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 = izamax( 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. disnan(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 a( k, k ) = dble( a( k, k ) )
301 ELSE
302*
303* ============================================================
304*
305* Test for interchange
306*
307 IF( absakk.GE.alpha*colmax ) THEN
308*
309* no interchange, use 1-by-1 pivot block
310*
311 kp = k
312 ELSE
313*
314* JMAX is the column-index of the largest off-diagonal
315* element in row IMAX, and ROWMAX is its absolute value.
316* Determine only ROWMAX.
317*
318 jmax = imax + izamax( k-imax, a( imax, imax+1 ), lda )
319 rowmax = cabs1( a( imax, jmax ) )
320 IF( imax.GT.1 ) THEN
321 jmax = izamax( imax-1, a( 1, imax ), 1 )
322 rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
323 END IF
324*
325 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
326*
327* no interchange, use 1-by-1 pivot block
328*
329 kp = k
330*
331 ELSE IF( abs( dble( a( imax, imax ) ) ).GE.alpha*rowmax )
332 $ THEN
333*
334* interchange rows and columns K and IMAX, use 1-by-1
335* pivot block
336*
337 kp = imax
338 ELSE
339*
340* interchange rows and columns K-1 and IMAX, use 2-by-2
341* pivot block
342*
343 kp = imax
344 kstep = 2
345 END IF
346*
347 END IF
348*
349* ============================================================
350*
351 kk = k - kstep + 1
352 IF( kp.NE.kk ) THEN
353*
354* Interchange rows and columns KK and KP in the leading
355* submatrix A(1:k,1:k)
356*
357 CALL zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
358 DO 20 j = kp + 1, kk - 1
359 t = dconjg( a( j, kk ) )
360 a( j, kk ) = dconjg( a( kp, j ) )
361 a( kp, j ) = t
362 20 CONTINUE
363 a( kp, kk ) = dconjg( a( kp, kk ) )
364 r1 = dble( a( kk, kk ) )
365 a( kk, kk ) = dble( a( kp, kp ) )
366 a( kp, kp ) = r1
367 IF( kstep.EQ.2 ) THEN
368 a( k, k ) = dble( a( k, k ) )
369 t = a( k-1, k )
370 a( k-1, k ) = a( kp, k )
371 a( kp, k ) = t
372 END IF
373 ELSE
374 a( k, k ) = dble( a( k, k ) )
375 IF( kstep.EQ.2 )
376 $ a( k-1, k-1 ) = dble( a( k-1, k-1 ) )
377 END IF
378*
379* Update the leading submatrix
380*
381 IF( kstep.EQ.1 ) THEN
382*
383* 1-by-1 pivot block D(k): column k now holds
384*
385* W(k) = U(k)*D(k)
386*
387* where U(k) is the k-th column of U
388*
389* Perform a rank-1 update of A(1:k-1,1:k-1) as
390*
391* A := A - U(k)*D(k)*U(k)**H = A - W(k)*1/D(k)*W(k)**H
392*
393 r1 = one / dble( a( k, k ) )
394 CALL zher( uplo, k-1, -r1, a( 1, k ), 1, a, lda )
395*
396* Store U(k) in column k
397*
398 CALL zdscal( k-1, r1, a( 1, k ), 1 )
399 ELSE
400*
401* 2-by-2 pivot block D(k): columns k and k-1 now hold
402*
403* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
404*
405* where U(k) and U(k-1) are the k-th and (k-1)-th columns
406* of U
407*
408* Perform a rank-2 update of A(1:k-2,1:k-2) as
409*
410* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**H
411* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**H
412*
413 IF( k.GT.2 ) THEN
414*
415 d = dlapy2( dble( a( k-1, k ) ),
416 $ dimag( a( k-1, k ) ) )
417 d22 = dble( a( k-1, k-1 ) ) / d
418 d11 = dble( a( k, k ) ) / d
419 tt = one / ( d11*d22-one )
420 d12 = a( k-1, k ) / d
421 d = tt / d
422*
423 DO 40 j = k - 2, 1, -1
424 wkm1 = d*( d11*a( j, k-1 )-dconjg( d12 )*
425 $ a( j, k ) )
426 wk = d*( d22*a( j, k )-d12*a( j, k-1 ) )
427 DO 30 i = j, 1, -1
428 a( i, j ) = a( i, j ) - a( i, k )*dconjg( wk ) -
429 $ a( i, k-1 )*dconjg( wkm1 )
430 30 CONTINUE
431 a( j, k ) = wk
432 a( j, k-1 ) = wkm1
433 a( j, j ) = dcmplx( dble( a( j, j ) ), 0.0d+0 )
434 40 CONTINUE
435*
436 END IF
437*
438 END IF
439 END IF
440*
441* Store details of the interchanges in IPIV
442*
443 IF( kstep.EQ.1 ) THEN
444 ipiv( k ) = kp
445 ELSE
446 ipiv( k ) = -kp
447 ipiv( k-1 ) = -kp
448 END IF
449*
450* Decrease K and return to the start of the main loop
451*
452 k = k - kstep
453 GO TO 10
454*
455 ELSE
456*
457* Factorize A as L*D*L**H using the lower triangle of A
458*
459* K is the main loop index, increasing from 1 to N in steps of
460* 1 or 2
461*
462 k = 1
463 50 CONTINUE
464*
465* If K > N, exit from loop
466*
467 IF( k.GT.n )
468 $ GO TO 90
469 kstep = 1
470*
471* Determine rows and columns to be interchanged and whether
472* a 1-by-1 or 2-by-2 pivot block will be used
473*
474 absakk = abs( dble( a( k, k ) ) )
475*
476* IMAX is the row-index of the largest off-diagonal element in
477* column K, and COLMAX is its absolute value.
478* Determine both COLMAX and IMAX.
479*
480 IF( k.LT.n ) THEN
481 imax = k + izamax( n-k, a( k+1, k ), 1 )
482 colmax = cabs1( a( imax, k ) )
483 ELSE
484 colmax = zero
485 END IF
486*
487 IF( (max( absakk, colmax ).EQ.zero) .OR. disnan(absakk) ) THEN
488*
489* Column K is zero or underflow, or contains a NaN:
490* set INFO and continue
491*
492 IF( info.EQ.0 )
493 $ info = k
494 kp = k
495 a( k, k ) = dble( a( k, k ) )
496 ELSE
497*
498* ============================================================
499*
500* Test for interchange
501*
502 IF( absakk.GE.alpha*colmax ) THEN
503*
504* no interchange, use 1-by-1 pivot block
505*
506 kp = k
507 ELSE
508*
509* JMAX is the column-index of the largest off-diagonal
510* element in row IMAX, and ROWMAX is its absolute value.
511* Determine only ROWMAX.
512*
513 jmax = k - 1 + izamax( imax-k, a( imax, k ), lda )
514 rowmax = cabs1( a( imax, jmax ) )
515 IF( imax.LT.n ) THEN
516 jmax = imax + izamax( n-imax, a( imax+1, imax ), 1 )
517 rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
518 END IF
519*
520 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
521*
522* no interchange, use 1-by-1 pivot block
523*
524 kp = k
525*
526 ELSE IF( abs( dble( a( imax, imax ) ) ).GE.alpha*rowmax )
527 $ THEN
528*
529* interchange rows and columns K and IMAX, use 1-by-1
530* pivot block
531*
532 kp = imax
533 ELSE
534*
535* interchange rows and columns K+1 and IMAX, use 2-by-2
536* pivot block
537*
538 kp = imax
539 kstep = 2
540 END IF
541*
542 END IF
543*
544* ============================================================
545*
546 kk = k + kstep - 1
547 IF( kp.NE.kk ) THEN
548*
549* Interchange rows and columns KK and KP in the trailing
550* submatrix A(k:n,k:n)
551*
552 IF( kp.LT.n )
553 $ CALL zswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
554 DO 60 j = kk + 1, kp - 1
555 t = dconjg( a( j, kk ) )
556 a( j, kk ) = dconjg( a( kp, j ) )
557 a( kp, j ) = t
558 60 CONTINUE
559 a( kp, kk ) = dconjg( a( kp, kk ) )
560 r1 = dble( a( kk, kk ) )
561 a( kk, kk ) = dble( a( kp, kp ) )
562 a( kp, kp ) = r1
563 IF( kstep.EQ.2 ) THEN
564 a( k, k ) = dble( a( k, k ) )
565 t = a( k+1, k )
566 a( k+1, k ) = a( kp, k )
567 a( kp, k ) = t
568 END IF
569 ELSE
570 a( k, k ) = dble( a( k, k ) )
571 IF( kstep.EQ.2 )
572 $ a( k+1, k+1 ) = dble( a( k+1, k+1 ) )
573 END IF
574*
575* Update the trailing submatrix
576*
577 IF( kstep.EQ.1 ) THEN
578*
579* 1-by-1 pivot block D(k): column k now holds
580*
581* W(k) = L(k)*D(k)
582*
583* where L(k) is the k-th column of L
584*
585 IF( k.LT.n ) THEN
586*
587* Perform a rank-1 update of A(k+1:n,k+1:n) as
588*
589* A := A - L(k)*D(k)*L(k)**H = A - W(k)*(1/D(k))*W(k)**H
590*
591 r1 = one / dble( a( k, k ) )
592 CALL zher( uplo, n-k, -r1, a( k+1, k ), 1,
593 $ a( k+1, k+1 ), lda )
594*
595* Store L(k) in column K
596*
597 CALL zdscal( n-k, r1, a( k+1, k ), 1 )
598 END IF
599 ELSE
600*
601* 2-by-2 pivot block D(k)
602*
603 IF( k.LT.n-1 ) THEN
604*
605* Perform a rank-2 update of A(k+2:n,k+2:n) as
606*
607* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**H
608* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**H
609*
610* where L(k) and L(k+1) are the k-th and (k+1)-th
611* columns of L
612*
613 d = dlapy2( dble( a( k+1, k ) ),
614 $ dimag( a( k+1, k ) ) )
615 d11 = dble( a( k+1, k+1 ) ) / d
616 d22 = dble( a( k, k ) ) / d
617 tt = one / ( d11*d22-one )
618 d21 = a( k+1, k ) / d
619 d = tt / d
620*
621 DO 80 j = k + 2, n
622 wk = d*( d11*a( j, k )-d21*a( j, k+1 ) )
623 wkp1 = d*( d22*a( j, k+1 )-dconjg( d21 )*
624 $ a( j, k ) )
625 DO 70 i = j, n
626 a( i, j ) = a( i, j ) - a( i, k )*dconjg( wk ) -
627 $ a( i, k+1 )*dconjg( wkp1 )
628 70 CONTINUE
629 a( j, k ) = wk
630 a( j, k+1 ) = wkp1
631 a( j, j ) = dcmplx( dble( a( j, j ) ), 0.0d+0 )
632 80 CONTINUE
633 END IF
634 END IF
635 END IF
636*
637* Store details of the interchanges in IPIV
638*
639 IF( kstep.EQ.1 ) THEN
640 ipiv( k ) = kp
641 ELSE
642 ipiv( k ) = -kp
643 ipiv( k+1 ) = -kp
644 END IF
645*
646* Increase K and return to the start of the main loop
647*
648 k = k + kstep
649 GO TO 50
650*
651 END IF
652*
653 90 CONTINUE
654 RETURN
655*
656* End of ZHETF2
657*
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63
integer function izamax(n, zx, incx)
IZAMAX
Definition izamax.f:71
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
subroutine zher(uplo, n, alpha, x, incx, a, lda)
ZHER
Definition zher.f:135

◆ zhetf2_rk()

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

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

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

Purpose:
!> ZHETF2_RK computes the factorization of a complex Hermitian matrix A
!> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!>
!>    A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**H (or L**H) is the conjugate of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is Hermitian 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
!>          Hermitian 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*16 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, contains:
!>            a) ONLY diagonal elements of the Hermitian 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*16 array, dimension (N)
!>          On exit, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian 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 Hermitian 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 zhetf2_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*16 A( LDA, * ), E( * )
253* ..
254*
255* ======================================================================
256*
257* .. Parameters ..
258 DOUBLE PRECISION ZERO, ONE
259 parameter( zero = 0.0d+0, one = 1.0d+0 )
260 DOUBLE PRECISION EIGHT, SEVTEN
261 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
262 COMPLEX*16 CZERO
263 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
264* ..
265* .. Local Scalars ..
266 LOGICAL DONE, UPPER
267 INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
268 $ P
269 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, DTEMP,
270 $ ROWMAX, TT, SFMIN
271 COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, Z
272* ..
273* .. External Functions ..
274*
275 LOGICAL LSAME
276 INTEGER IZAMAX
277 DOUBLE PRECISION DLAMCH, DLAPY2
278 EXTERNAL lsame, izamax, dlamch, dlapy2
279* ..
280* .. External Subroutines ..
281 EXTERNAL xerbla, zdscal, zher, zswap
282* ..
283* .. Intrinsic Functions ..
284 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, sqrt
285* ..
286* .. Statement Functions ..
287 DOUBLE PRECISION CABS1
288* ..
289* .. Statement Function definitions ..
290 cabs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
291* ..
292* .. Executable Statements ..
293*
294* Test the input parameters.
295*
296 info = 0
297 upper = lsame( uplo, 'U' )
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 END IF
305 IF( info.NE.0 ) THEN
306 CALL xerbla( 'ZHETF2_RK', -info )
307 RETURN
308 END IF
309*
310* Initialize ALPHA for use in choosing pivot block size.
311*
312 alpha = ( one+sqrt( sevten ) ) / eight
313*
314* Compute machine safe minimum
315*
316 sfmin = dlamch( 'S' )
317*
318 IF( upper ) THEN
319*
320* Factorize A as U*D*U**H using the upper triangle of A
321*
322* Initialize the first entry of array E, where superdiagonal
323* elements of D are stored
324*
325 e( 1 ) = czero
326*
327* K is the main loop index, decreasing from N to 1 in steps of
328* 1 or 2
329*
330 k = n
331 10 CONTINUE
332*
333* If K < 1, exit from loop
334*
335 IF( k.LT.1 )
336 $ GO TO 34
337 kstep = 1
338 p = k
339*
340* Determine rows and columns to be interchanged and whether
341* a 1-by-1 or 2-by-2 pivot block will be used
342*
343 absakk = abs( dble( a( k, k ) ) )
344*
345* IMAX is the row-index of the largest off-diagonal element in
346* column K, and COLMAX is its absolute value.
347* Determine both COLMAX and IMAX.
348*
349 IF( k.GT.1 ) THEN
350 imax = izamax( k-1, a( 1, k ), 1 )
351 colmax = cabs1( a( imax, k ) )
352 ELSE
353 colmax = zero
354 END IF
355*
356 IF( ( max( absakk, colmax ).EQ.zero ) ) THEN
357*
358* Column K is zero or underflow: set INFO and continue
359*
360 IF( info.EQ.0 )
361 $ info = k
362 kp = k
363 a( k, k ) = dble( a( k, k ) )
364*
365* Set E( K ) to zero
366*
367 IF( k.GT.1 )
368 $ e( k ) = czero
369*
370 ELSE
371*
372* ============================================================
373*
374* BEGIN pivot search
375*
376* Case(1)
377* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
378* (used to handle NaN and Inf)
379*
380 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
381*
382* no interchange, use 1-by-1 pivot block
383*
384 kp = k
385*
386 ELSE
387*
388 done = .false.
389*
390* Loop until pivot found
391*
392 12 CONTINUE
393*
394* BEGIN pivot search loop body
395*
396*
397* JMAX is the column-index of the largest off-diagonal
398* element in row IMAX, and ROWMAX is its absolute value.
399* Determine both ROWMAX and JMAX.
400*
401 IF( imax.NE.k ) THEN
402 jmax = imax + izamax( k-imax, a( imax, imax+1 ),
403 $ lda )
404 rowmax = cabs1( a( imax, jmax ) )
405 ELSE
406 rowmax = zero
407 END IF
408*
409 IF( imax.GT.1 ) THEN
410 itemp = izamax( imax-1, a( 1, imax ), 1 )
411 dtemp = cabs1( a( itemp, imax ) )
412 IF( dtemp.GT.rowmax ) THEN
413 rowmax = dtemp
414 jmax = itemp
415 END IF
416 END IF
417*
418* Case(2)
419* Equivalent to testing for
420* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
421* (used to handle NaN and Inf)
422*
423 IF( .NOT.( abs( dble( a( imax, imax ) ) )
424 $ .LT.alpha*rowmax ) ) THEN
425*
426* interchange rows and columns K and IMAX,
427* use 1-by-1 pivot block
428*
429 kp = imax
430 done = .true.
431*
432* Case(3)
433* Equivalent to testing for ROWMAX.EQ.COLMAX,
434* (used to handle NaN and Inf)
435*
436 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
437 $ THEN
438*
439* interchange rows and columns K-1 and IMAX,
440* use 2-by-2 pivot block
441*
442 kp = imax
443 kstep = 2
444 done = .true.
445*
446* Case(4)
447 ELSE
448*
449* Pivot not found: set params and repeat
450*
451 p = imax
452 colmax = rowmax
453 imax = jmax
454 END IF
455*
456* END pivot search loop body
457*
458 IF( .NOT.done ) GOTO 12
459*
460 END IF
461*
462* END pivot search
463*
464* ============================================================
465*
466* KK is the column of A where pivoting step stopped
467*
468 kk = k - kstep + 1
469*
470* For only a 2x2 pivot, interchange rows and columns K and P
471* in the leading submatrix A(1:k,1:k)
472*
473 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
474* (1) Swap columnar parts
475 IF( p.GT.1 )
476 $ CALL zswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
477* (2) Swap and conjugate middle parts
478 DO 14 j = p + 1, k - 1
479 t = dconjg( a( j, k ) )
480 a( j, k ) = dconjg( a( p, j ) )
481 a( p, j ) = t
482 14 CONTINUE
483* (3) Swap and conjugate corner elements at row-col interserction
484 a( p, k ) = dconjg( a( p, k ) )
485* (4) Swap diagonal elements at row-col intersection
486 r1 = dble( a( k, k ) )
487 a( k, k ) = dble( a( p, p ) )
488 a( p, p ) = r1
489*
490* Convert upper triangle of A into U form by applying
491* the interchanges in columns k+1:N.
492*
493 IF( k.LT.n )
494 $ CALL zswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
495*
496 END IF
497*
498* For both 1x1 and 2x2 pivots, interchange rows and
499* columns KK and KP in the leading submatrix A(1:k,1:k)
500*
501 IF( kp.NE.kk ) THEN
502* (1) Swap columnar parts
503 IF( kp.GT.1 )
504 $ CALL zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
505* (2) Swap and conjugate middle parts
506 DO 15 j = kp + 1, kk - 1
507 t = dconjg( a( j, kk ) )
508 a( j, kk ) = dconjg( a( kp, j ) )
509 a( kp, j ) = t
510 15 CONTINUE
511* (3) Swap and conjugate corner elements at row-col interserction
512 a( kp, kk ) = dconjg( a( kp, kk ) )
513* (4) Swap diagonal elements at row-col intersection
514 r1 = dble( a( kk, kk ) )
515 a( kk, kk ) = dble( a( kp, kp ) )
516 a( kp, kp ) = r1
517*
518 IF( kstep.EQ.2 ) THEN
519* (*) Make sure that diagonal element of pivot is real
520 a( k, k ) = dble( a( k, k ) )
521* (5) Swap row elements
522 t = a( k-1, k )
523 a( k-1, k ) = a( kp, k )
524 a( kp, k ) = t
525 END IF
526*
527* Convert upper triangle of A into U form by applying
528* the interchanges in columns k+1:N.
529*
530 IF( k.LT.n )
531 $ CALL zswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
532 $ lda )
533*
534 ELSE
535* (*) Make sure that diagonal element of pivot is real
536 a( k, k ) = dble( a( k, k ) )
537 IF( kstep.EQ.2 )
538 $ a( k-1, k-1 ) = dble( a( k-1, k-1 ) )
539 END IF
540*
541* Update the leading submatrix
542*
543 IF( kstep.EQ.1 ) THEN
544*
545* 1-by-1 pivot block D(k): column k now holds
546*
547* W(k) = U(k)*D(k)
548*
549* where U(k) is the k-th column of U
550*
551 IF( k.GT.1 ) THEN
552*
553* Perform a rank-1 update of A(1:k-1,1:k-1) and
554* store U(k) in column k
555*
556 IF( abs( dble( a( k, k ) ) ).GE.sfmin ) THEN
557*
558* Perform a rank-1 update of A(1:k-1,1:k-1) as
559* A := A - U(k)*D(k)*U(k)**T
560* = A - W(k)*1/D(k)*W(k)**T
561*
562 d11 = one / dble( a( k, k ) )
563 CALL zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
564*
565* Store U(k) in column k
566*
567 CALL zdscal( k-1, d11, a( 1, k ), 1 )
568 ELSE
569*
570* Store L(k) in column K
571*
572 d11 = dble( a( k, k ) )
573 DO 16 ii = 1, k - 1
574 a( ii, k ) = a( ii, k ) / d11
575 16 CONTINUE
576*
577* Perform a rank-1 update of A(k+1:n,k+1:n) as
578* A := A - U(k)*D(k)*U(k)**T
579* = A - W(k)*(1/D(k))*W(k)**T
580* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
581*
582 CALL zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
583 END IF
584*
585* Store the superdiagonal element of D in array E
586*
587 e( k ) = czero
588*
589 END IF
590*
591 ELSE
592*
593* 2-by-2 pivot block D(k): columns k and k-1 now hold
594*
595* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
596*
597* where U(k) and U(k-1) are the k-th and (k-1)-th columns
598* of U
599*
600* Perform a rank-2 update of A(1:k-2,1:k-2) as
601*
602* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
603* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
604*
605* and store L(k) and L(k+1) in columns k and k+1
606*
607 IF( k.GT.2 ) THEN
608* D = |A12|
609 d = dlapy2( dble( a( k-1, k ) ),
610 $ dimag( a( k-1, k ) ) )
611 d11 = dble( a( k, k ) / d )
612 d22 = dble( a( k-1, k-1 ) / d )
613 d12 = a( k-1, k ) / d
614 tt = one / ( d11*d22-one )
615*
616 DO 30 j = k - 2, 1, -1
617*
618* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
619*
620 wkm1 = tt*( d11*a( j, k-1 )-dconjg( d12 )*
621 $ a( j, k ) )
622 wk = tt*( d22*a( j, k )-d12*a( j, k-1 ) )
623*
624* Perform a rank-2 update of A(1:k-2,1:k-2)
625*
626 DO 20 i = j, 1, -1
627 a( i, j ) = a( i, j ) -
628 $ ( a( i, k ) / d )*dconjg( wk ) -
629 $ ( a( i, k-1 ) / d )*dconjg( wkm1 )
630 20 CONTINUE
631*
632* Store U(k) and U(k-1) in cols k and k-1 for row J
633*
634 a( j, k ) = wk / d
635 a( j, k-1 ) = wkm1 / d
636* (*) Make sure that diagonal element of pivot is real
637 a( j, j ) = dcmplx( dble( a( j, j ) ), zero )
638*
639 30 CONTINUE
640*
641 END IF
642*
643* Copy superdiagonal elements of D(K) to E(K) and
644* ZERO out superdiagonal entry of A
645*
646 e( k ) = a( k-1, k )
647 e( k-1 ) = czero
648 a( k-1, k ) = czero
649*
650 END IF
651*
652* End column K is nonsingular
653*
654 END IF
655*
656* Store details of the interchanges in IPIV
657*
658 IF( kstep.EQ.1 ) THEN
659 ipiv( k ) = kp
660 ELSE
661 ipiv( k ) = -p
662 ipiv( k-1 ) = -kp
663 END IF
664*
665* Decrease K and return to the start of the main loop
666*
667 k = k - kstep
668 GO TO 10
669*
670 34 CONTINUE
671*
672 ELSE
673*
674* Factorize A as L*D*L**H using the lower triangle of A
675*
676* Initialize the unused last entry of the subdiagonal array E.
677*
678 e( n ) = czero
679*
680* K is the main loop index, increasing from 1 to N in steps of
681* 1 or 2
682*
683 k = 1
684 40 CONTINUE
685*
686* If K > N, exit from loop
687*
688 IF( k.GT.n )
689 $ GO TO 64
690 kstep = 1
691 p = k
692*
693* Determine rows and columns to be interchanged and whether
694* a 1-by-1 or 2-by-2 pivot block will be used
695*
696 absakk = abs( dble( a( k, k ) ) )
697*
698* IMAX is the row-index of the largest off-diagonal element in
699* column K, and COLMAX is its absolute value.
700* Determine both COLMAX and IMAX.
701*
702 IF( k.LT.n ) THEN
703 imax = k + izamax( n-k, a( k+1, k ), 1 )
704 colmax = cabs1( a( imax, k ) )
705 ELSE
706 colmax = zero
707 END IF
708*
709 IF( max( absakk, colmax ).EQ.zero ) THEN
710*
711* Column K is zero or underflow: set INFO and continue
712*
713 IF( info.EQ.0 )
714 $ info = k
715 kp = k
716 a( k, k ) = dble( a( k, k ) )
717*
718* Set E( K ) to zero
719*
720 IF( k.LT.n )
721 $ e( k ) = czero
722*
723 ELSE
724*
725* ============================================================
726*
727* BEGIN pivot search
728*
729* Case(1)
730* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
731* (used to handle NaN and Inf)
732*
733 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
734*
735* no interchange, use 1-by-1 pivot block
736*
737 kp = k
738*
739 ELSE
740*
741 done = .false.
742*
743* Loop until pivot found
744*
745 42 CONTINUE
746*
747* BEGIN pivot search loop body
748*
749*
750* JMAX is the column-index of the largest off-diagonal
751* element in row IMAX, and ROWMAX is its absolute value.
752* Determine both ROWMAX and JMAX.
753*
754 IF( imax.NE.k ) THEN
755 jmax = k - 1 + izamax( imax-k, a( imax, k ), lda )
756 rowmax = cabs1( a( imax, jmax ) )
757 ELSE
758 rowmax = zero
759 END IF
760*
761 IF( imax.LT.n ) THEN
762 itemp = imax + izamax( n-imax, a( imax+1, imax ),
763 $ 1 )
764 dtemp = cabs1( a( itemp, imax ) )
765 IF( dtemp.GT.rowmax ) THEN
766 rowmax = dtemp
767 jmax = itemp
768 END IF
769 END IF
770*
771* Case(2)
772* Equivalent to testing for
773* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
774* (used to handle NaN and Inf)
775*
776 IF( .NOT.( abs( dble( a( imax, imax ) ) )
777 $ .LT.alpha*rowmax ) ) THEN
778*
779* interchange rows and columns K and IMAX,
780* use 1-by-1 pivot block
781*
782 kp = imax
783 done = .true.
784*
785* Case(3)
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*
799* Case(4)
800 ELSE
801*
802* Pivot not found: set params and repeat
803*
804 p = imax
805 colmax = rowmax
806 imax = jmax
807 END IF
808*
809*
810* END pivot search loop body
811*
812 IF( .NOT.done ) GOTO 42
813*
814 END IF
815*
816* END pivot search
817*
818* ============================================================
819*
820* KK is the column of A where pivoting step stopped
821*
822 kk = k + kstep - 1
823*
824* For only a 2x2 pivot, interchange rows and columns K and P
825* in the trailing submatrix A(k:n,k:n)
826*
827 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
828* (1) Swap columnar parts
829 IF( p.LT.n )
830 $ CALL zswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
831* (2) Swap and conjugate middle parts
832 DO 44 j = k + 1, p - 1
833 t = dconjg( a( j, k ) )
834 a( j, k ) = dconjg( a( p, j ) )
835 a( p, j ) = t
836 44 CONTINUE
837* (3) Swap and conjugate corner elements at row-col interserction
838 a( p, k ) = dconjg( a( p, k ) )
839* (4) Swap diagonal elements at row-col intersection
840 r1 = dble( a( k, k ) )
841 a( k, k ) = dble( a( p, p ) )
842 a( p, p ) = r1
843*
844* Convert lower triangle of A into L form by applying
845* the interchanges in columns 1:k-1.
846*
847 IF ( k.GT.1 )
848 $ CALL zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda )
849*
850 END IF
851*
852* For both 1x1 and 2x2 pivots, interchange rows and
853* columns KK and KP in the trailing submatrix A(k:n,k:n)
854*
855 IF( kp.NE.kk ) THEN
856* (1) Swap columnar parts
857 IF( kp.LT.n )
858 $ CALL zswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
859* (2) Swap and conjugate middle parts
860 DO 45 j = kk + 1, kp - 1
861 t = dconjg( a( j, kk ) )
862 a( j, kk ) = dconjg( a( kp, j ) )
863 a( kp, j ) = t
864 45 CONTINUE
865* (3) Swap and conjugate corner elements at row-col interserction
866 a( kp, kk ) = dconjg( a( kp, kk ) )
867* (4) Swap diagonal elements at row-col intersection
868 r1 = dble( a( kk, kk ) )
869 a( kk, kk ) = dble( a( kp, kp ) )
870 a( kp, kp ) = r1
871*
872 IF( kstep.EQ.2 ) THEN
873* (*) Make sure that diagonal element of pivot is real
874 a( k, k ) = dble( a( k, k ) )
875* (5) Swap row elements
876 t = a( k+1, k )
877 a( k+1, k ) = a( kp, k )
878 a( kp, k ) = t
879 END IF
880*
881* Convert lower triangle of A into L form by applying
882* the interchanges in columns 1:k-1.
883*
884 IF ( k.GT.1 )
885 $ CALL zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
886*
887 ELSE
888* (*) Make sure that diagonal element of pivot is real
889 a( k, k ) = dble( a( k, k ) )
890 IF( kstep.EQ.2 )
891 $ a( k+1, k+1 ) = dble( a( k+1, k+1 ) )
892 END IF
893*
894* Update the trailing submatrix
895*
896 IF( kstep.EQ.1 ) THEN
897*
898* 1-by-1 pivot block D(k): column k of A now holds
899*
900* W(k) = L(k)*D(k),
901*
902* where L(k) is the k-th column of L
903*
904 IF( k.LT.n ) THEN
905*
906* Perform a rank-1 update of A(k+1:n,k+1:n) and
907* store L(k) in column k
908*
909* Handle division by a small number
910*
911 IF( abs( dble( a( k, k ) ) ).GE.sfmin ) THEN
912*
913* Perform a rank-1 update of A(k+1:n,k+1:n) as
914* A := A - L(k)*D(k)*L(k)**T
915* = A - W(k)*(1/D(k))*W(k)**T
916*
917 d11 = one / dble( a( k, k ) )
918 CALL zher( uplo, n-k, -d11, a( k+1, k ), 1,
919 $ a( k+1, k+1 ), lda )
920*
921* Store L(k) in column k
922*
923 CALL zdscal( n-k, d11, a( k+1, k ), 1 )
924 ELSE
925*
926* Store L(k) in column k
927*
928 d11 = dble( a( k, k ) )
929 DO 46 ii = k + 1, n
930 a( ii, k ) = a( ii, k ) / d11
931 46 CONTINUE
932*
933* Perform a rank-1 update of A(k+1:n,k+1:n) as
934* A := A - L(k)*D(k)*L(k)**T
935* = A - W(k)*(1/D(k))*W(k)**T
936* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
937*
938 CALL zher( uplo, n-k, -d11, a( k+1, k ), 1,
939 $ a( k+1, k+1 ), lda )
940 END IF
941*
942* Store the subdiagonal element of D in array E
943*
944 e( k ) = czero
945*
946 END IF
947*
948 ELSE
949*
950* 2-by-2 pivot block D(k): columns k and k+1 now hold
951*
952* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
953*
954* where L(k) and L(k+1) are the k-th and (k+1)-th columns
955* of L
956*
957*
958* Perform a rank-2 update of A(k+2:n,k+2:n) as
959*
960* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
961* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
962*
963* and store L(k) and L(k+1) in columns k and k+1
964*
965 IF( k.LT.n-1 ) THEN
966* D = |A21|
967 d = dlapy2( dble( a( k+1, k ) ),
968 $ dimag( a( k+1, k ) ) )
969 d11 = dble( a( k+1, k+1 ) ) / d
970 d22 = dble( a( k, k ) ) / d
971 d21 = a( k+1, k ) / d
972 tt = one / ( d11*d22-one )
973*
974 DO 60 j = k + 2, n
975*
976* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
977*
978 wk = tt*( d11*a( j, k )-d21*a( j, k+1 ) )
979 wkp1 = tt*( d22*a( j, k+1 )-dconjg( d21 )*
980 $ a( j, k ) )
981*
982* Perform a rank-2 update of A(k+2:n,k+2:n)
983*
984 DO 50 i = j, n
985 a( i, j ) = a( i, j ) -
986 $ ( a( i, k ) / d )*dconjg( wk ) -
987 $ ( a( i, k+1 ) / d )*dconjg( wkp1 )
988 50 CONTINUE
989*
990* Store L(k) and L(k+1) in cols k and k+1 for row J
991*
992 a( j, k ) = wk / d
993 a( j, k+1 ) = wkp1 / d
994* (*) Make sure that diagonal element of pivot is real
995 a( j, j ) = dcmplx( dble( a( j, j ) ), zero )
996*
997 60 CONTINUE
998*
999 END IF
1000*
1001* Copy subdiagonal elements of D(K) to E(K) and
1002* ZERO out subdiagonal entry of A
1003*
1004 e( k ) = a( k+1, k )
1005 e( k+1 ) = czero
1006 a( k+1, k ) = czero
1007*
1008 END IF
1009*
1010* End column K is nonsingular
1011*
1012 END IF
1013*
1014* Store details of the interchanges in IPIV
1015*
1016 IF( kstep.EQ.1 ) THEN
1017 ipiv( k ) = kp
1018 ELSE
1019 ipiv( k ) = -p
1020 ipiv( k+1 ) = -kp
1021 END IF
1022*
1023* Increase K and return to the start of the main loop
1024*
1025 k = k + kstep
1026 GO TO 40
1027*
1028 64 CONTINUE
1029*
1030 END IF
1031*
1032 RETURN
1033*
1034* End of ZHETF2_RK
1035*

◆ zhetf2_rook()

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

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

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

Purpose:
!>
!> ZHETF2_ROOK computes the factorization of a complex Hermitian matrix A
!> using the bounded Bunch-Kaufman () diagonal pivoting method:
!>
!>    A = U*D*U**H  or  A = L*D*L**H
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, U**H is the conjugate transpose of U, and D is
!> Hermitian 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
!>          Hermitian 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*16 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, 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**H, 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**H, 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, USA
!> 

Definition at line 193 of file zhetf2_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*16 A( LDA, * )
206* ..
207*
208* ======================================================================
209*
210* .. Parameters ..
211 DOUBLE PRECISION ZERO, ONE
212 parameter( zero = 0.0d+0, one = 1.0d+0 )
213 DOUBLE PRECISION EIGHT, SEVTEN
214 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
215* ..
216* .. Local Scalars ..
217 LOGICAL DONE, UPPER
218 INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
219 $ P
220 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, DTEMP,
221 $ ROWMAX, TT, SFMIN
222 COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, Z
223* ..
224* .. External Functions ..
225*
226 LOGICAL LSAME
227 INTEGER IZAMAX
228 DOUBLE PRECISION DLAMCH, DLAPY2
229 EXTERNAL lsame, izamax, dlamch, dlapy2
230* ..
231* .. External Subroutines ..
232 EXTERNAL xerbla, zdscal, zher, zswap
233* ..
234* .. Intrinsic Functions ..
235 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, sqrt
236* ..
237* .. Statement Functions ..
238 DOUBLE PRECISION CABS1
239* ..
240* .. Statement Function definitions ..
241 cabs1( z ) = abs( dble( z ) ) + abs( dimag( 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( 'ZHETF2_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 = dlamch( 'S' )
268*
269 IF( upper ) THEN
270*
271* Factorize A as U*D*U**H 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 = abs( dble( 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 = izamax( 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 a( k, k ) = dble( a( k, k ) )
310 ELSE
311*
312* ============================================================
313*
314* BEGIN pivot search
315*
316* Case(1)
317* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
318* (used to handle NaN and Inf)
319*
320 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
321*
322* no interchange, use 1-by-1 pivot block
323*
324 kp = k
325*
326 ELSE
327*
328 done = .false.
329*
330* Loop until pivot found
331*
332 12 CONTINUE
333*
334* BEGIN pivot search loop body
335*
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 + izamax( k-imax, a( imax, imax+1 ),
343 $ lda )
344 rowmax = cabs1( a( imax, jmax ) )
345 ELSE
346 rowmax = zero
347 END IF
348*
349 IF( imax.GT.1 ) THEN
350 itemp = izamax( imax-1, a( 1, imax ), 1 )
351 dtemp = cabs1( a( itemp, imax ) )
352 IF( dtemp.GT.rowmax ) THEN
353 rowmax = dtemp
354 jmax = itemp
355 END IF
356 END IF
357*
358* Case(2)
359* Equivalent to testing for
360* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
361* (used to handle NaN and Inf)
362*
363 IF( .NOT.( abs( dble( a( imax, imax ) ) )
364 $ .LT.alpha*rowmax ) ) THEN
365*
366* interchange rows and columns K and IMAX,
367* use 1-by-1 pivot block
368*
369 kp = imax
370 done = .true.
371*
372* Case(3)
373* Equivalent to testing for ROWMAX.EQ.COLMAX,
374* (used to handle NaN and Inf)
375*
376 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
377 $ THEN
378*
379* interchange rows and columns K-1 and IMAX,
380* use 2-by-2 pivot block
381*
382 kp = imax
383 kstep = 2
384 done = .true.
385*
386* Case(4)
387 ELSE
388*
389* Pivot not found: set params and repeat
390*
391 p = imax
392 colmax = rowmax
393 imax = jmax
394 END IF
395*
396* END pivot search loop body
397*
398 IF( .NOT.done ) GOTO 12
399*
400 END IF
401*
402* END pivot search
403*
404* ============================================================
405*
406* KK is the column of A where pivoting step stopped
407*
408 kk = k - kstep + 1
409*
410* For only a 2x2 pivot, interchange rows and columns K and P
411* in the leading submatrix A(1:k,1:k)
412*
413 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
414* (1) Swap columnar parts
415 IF( p.GT.1 )
416 $ CALL zswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
417* (2) Swap and conjugate middle parts
418 DO 14 j = p + 1, k - 1
419 t = dconjg( a( j, k ) )
420 a( j, k ) = dconjg( a( p, j ) )
421 a( p, j ) = t
422 14 CONTINUE
423* (3) Swap and conjugate corner elements at row-col interserction
424 a( p, k ) = dconjg( a( p, k ) )
425* (4) Swap diagonal elements at row-col intersection
426 r1 = dble( a( k, k ) )
427 a( k, k ) = dble( a( p, p ) )
428 a( p, p ) = r1
429 END IF
430*
431* For both 1x1 and 2x2 pivots, interchange rows and
432* columns KK and KP in the leading submatrix A(1:k,1:k)
433*
434 IF( kp.NE.kk ) THEN
435* (1) Swap columnar parts
436 IF( kp.GT.1 )
437 $ CALL zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
438* (2) Swap and conjugate middle parts
439 DO 15 j = kp + 1, kk - 1
440 t = dconjg( a( j, kk ) )
441 a( j, kk ) = dconjg( a( kp, j ) )
442 a( kp, j ) = t
443 15 CONTINUE
444* (3) Swap and conjugate corner elements at row-col interserction
445 a( kp, kk ) = dconjg( a( kp, kk ) )
446* (4) Swap diagonal elements at row-col intersection
447 r1 = dble( a( kk, kk ) )
448 a( kk, kk ) = dble( a( kp, kp ) )
449 a( kp, kp ) = r1
450*
451 IF( kstep.EQ.2 ) THEN
452* (*) Make sure that diagonal element of pivot is real
453 a( k, k ) = dble( a( k, k ) )
454* (5) Swap row elements
455 t = a( k-1, k )
456 a( k-1, k ) = a( kp, k )
457 a( kp, k ) = t
458 END IF
459 ELSE
460* (*) Make sure that diagonal element of pivot is real
461 a( k, k ) = dble( a( k, k ) )
462 IF( kstep.EQ.2 )
463 $ a( k-1, k-1 ) = dble( a( k-1, k-1 ) )
464 END IF
465*
466* Update the leading submatrix
467*
468 IF( kstep.EQ.1 ) THEN
469*
470* 1-by-1 pivot block D(k): column k now holds
471*
472* W(k) = U(k)*D(k)
473*
474* where U(k) is the k-th column of U
475*
476 IF( k.GT.1 ) THEN
477*
478* Perform a rank-1 update of A(1:k-1,1:k-1) and
479* store U(k) in column k
480*
481 IF( abs( dble( a( k, k ) ) ).GE.sfmin ) THEN
482*
483* Perform a rank-1 update of A(1:k-1,1:k-1) as
484* A := A - U(k)*D(k)*U(k)**T
485* = A - W(k)*1/D(k)*W(k)**T
486*
487 d11 = one / dble( a( k, k ) )
488 CALL zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
489*
490* Store U(k) in column k
491*
492 CALL zdscal( k-1, d11, a( 1, k ), 1 )
493 ELSE
494*
495* Store L(k) in column K
496*
497 d11 = dble( a( k, k ) )
498 DO 16 ii = 1, k - 1
499 a( ii, k ) = a( ii, k ) / d11
500 16 CONTINUE
501*
502* Perform a rank-1 update of A(k+1:n,k+1:n) as
503* A := A - U(k)*D(k)*U(k)**T
504* = A - W(k)*(1/D(k))*W(k)**T
505* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
506*
507 CALL zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
508 END IF
509 END IF
510*
511 ELSE
512*
513* 2-by-2 pivot block D(k): columns k and k-1 now hold
514*
515* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
516*
517* where U(k) and U(k-1) are the k-th and (k-1)-th columns
518* of U
519*
520* Perform a rank-2 update of A(1:k-2,1:k-2) as
521*
522* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
523* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
524*
525* and store L(k) and L(k+1) in columns k and k+1
526*
527 IF( k.GT.2 ) THEN
528* D = |A12|
529 d = dlapy2( dble( a( k-1, k ) ),
530 $ dimag( a( k-1, k ) ) )
531 d11 = dble( a( k, k ) / d )
532 d22 = dble( a( k-1, k-1 ) / d )
533 d12 = a( k-1, k ) / d
534 tt = one / ( d11*d22-one )
535*
536 DO 30 j = k - 2, 1, -1
537*
538* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
539*
540 wkm1 = tt*( d11*a( j, k-1 )-dconjg( d12 )*
541 $ a( j, k ) )
542 wk = tt*( d22*a( j, k )-d12*a( j, k-1 ) )
543*
544* Perform a rank-2 update of A(1:k-2,1:k-2)
545*
546 DO 20 i = j, 1, -1
547 a( i, j ) = a( i, j ) -
548 $ ( a( i, k ) / d )*dconjg( wk ) -
549 $ ( a( i, k-1 ) / d )*dconjg( wkm1 )
550 20 CONTINUE
551*
552* Store U(k) and U(k-1) in cols k and k-1 for row J
553*
554 a( j, k ) = wk / d
555 a( j, k-1 ) = wkm1 / d
556* (*) Make sure that diagonal element of pivot is real
557 a( j, j ) = dcmplx( dble( a( j, j ) ), zero )
558*
559 30 CONTINUE
560*
561 END IF
562*
563 END IF
564*
565 END IF
566*
567* Store details of the interchanges in IPIV
568*
569 IF( kstep.EQ.1 ) THEN
570 ipiv( k ) = kp
571 ELSE
572 ipiv( k ) = -p
573 ipiv( k-1 ) = -kp
574 END IF
575*
576* Decrease K and return to the start of the main loop
577*
578 k = k - kstep
579 GO TO 10
580*
581 ELSE
582*
583* Factorize A as L*D*L**H using the lower triangle of A
584*
585* K is the main loop index, increasing from 1 to N in steps of
586* 1 or 2
587*
588 k = 1
589 40 CONTINUE
590*
591* If K > N, exit from loop
592*
593 IF( k.GT.n )
594 $ GO TO 70
595 kstep = 1
596 p = k
597*
598* Determine rows and columns to be interchanged and whether
599* a 1-by-1 or 2-by-2 pivot block will be used
600*
601 absakk = abs( dble( a( k, k ) ) )
602*
603* IMAX is the row-index of the largest off-diagonal element in
604* column K, and COLMAX is its absolute value.
605* Determine both COLMAX and IMAX.
606*
607 IF( k.LT.n ) THEN
608 imax = k + izamax( n-k, a( k+1, k ), 1 )
609 colmax = cabs1( a( imax, k ) )
610 ELSE
611 colmax = zero
612 END IF
613*
614 IF( max( absakk, colmax ).EQ.zero ) THEN
615*
616* Column K is zero or underflow: set INFO and continue
617*
618 IF( info.EQ.0 )
619 $ info = k
620 kp = k
621 a( k, k ) = dble( a( k, k ) )
622 ELSE
623*
624* ============================================================
625*
626* BEGIN pivot search
627*
628* Case(1)
629* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
630* (used to handle NaN and Inf)
631*
632 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
633*
634* no interchange, use 1-by-1 pivot block
635*
636 kp = k
637*
638 ELSE
639*
640 done = .false.
641*
642* Loop until pivot found
643*
644 42 CONTINUE
645*
646* BEGIN pivot search loop body
647*
648*
649* JMAX is the column-index of the largest off-diagonal
650* element in row IMAX, and ROWMAX is its absolute value.
651* Determine both ROWMAX and JMAX.
652*
653 IF( imax.NE.k ) THEN
654 jmax = k - 1 + izamax( imax-k, a( imax, k ), lda )
655 rowmax = cabs1( a( imax, jmax ) )
656 ELSE
657 rowmax = zero
658 END IF
659*
660 IF( imax.LT.n ) THEN
661 itemp = imax + izamax( n-imax, a( imax+1, imax ),
662 $ 1 )
663 dtemp = cabs1( a( itemp, imax ) )
664 IF( dtemp.GT.rowmax ) THEN
665 rowmax = dtemp
666 jmax = itemp
667 END IF
668 END IF
669*
670* Case(2)
671* Equivalent to testing for
672* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
673* (used to handle NaN and Inf)
674*
675 IF( .NOT.( abs( dble( a( imax, imax ) ) )
676 $ .LT.alpha*rowmax ) ) THEN
677*
678* interchange rows and columns K and IMAX,
679* use 1-by-1 pivot block
680*
681 kp = imax
682 done = .true.
683*
684* Case(3)
685* Equivalent to testing for ROWMAX.EQ.COLMAX,
686* (used to handle NaN and Inf)
687*
688 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
689 $ THEN
690*
691* interchange rows and columns K+1 and IMAX,
692* use 2-by-2 pivot block
693*
694 kp = imax
695 kstep = 2
696 done = .true.
697*
698* Case(4)
699 ELSE
700*
701* Pivot not found: set params and repeat
702*
703 p = imax
704 colmax = rowmax
705 imax = jmax
706 END IF
707*
708*
709* END pivot search loop body
710*
711 IF( .NOT.done ) GOTO 42
712*
713 END IF
714*
715* END pivot search
716*
717* ============================================================
718*
719* KK is the column of A where pivoting step stopped
720*
721 kk = k + kstep - 1
722*
723* For only a 2x2 pivot, interchange rows and columns K and P
724* in the trailing submatrix A(k:n,k:n)
725*
726 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
727* (1) Swap columnar parts
728 IF( p.LT.n )
729 $ CALL zswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
730* (2) Swap and conjugate middle parts
731 DO 44 j = k + 1, p - 1
732 t = dconjg( a( j, k ) )
733 a( j, k ) = dconjg( a( p, j ) )
734 a( p, j ) = t
735 44 CONTINUE
736* (3) Swap and conjugate corner elements at row-col interserction
737 a( p, k ) = dconjg( a( p, k ) )
738* (4) Swap diagonal elements at row-col intersection
739 r1 = dble( a( k, k ) )
740 a( k, k ) = dble( a( p, p ) )
741 a( p, p ) = r1
742 END IF
743*
744* For both 1x1 and 2x2 pivots, interchange rows and
745* columns KK and KP in the trailing submatrix A(k:n,k:n)
746*
747 IF( kp.NE.kk ) THEN
748* (1) Swap columnar parts
749 IF( kp.LT.n )
750 $ CALL zswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
751* (2) Swap and conjugate middle parts
752 DO 45 j = kk + 1, kp - 1
753 t = dconjg( a( j, kk ) )
754 a( j, kk ) = dconjg( a( kp, j ) )
755 a( kp, j ) = t
756 45 CONTINUE
757* (3) Swap and conjugate corner elements at row-col interserction
758 a( kp, kk ) = dconjg( a( kp, kk ) )
759* (4) Swap diagonal elements at row-col intersection
760 r1 = dble( a( kk, kk ) )
761 a( kk, kk ) = dble( a( kp, kp ) )
762 a( kp, kp ) = r1
763*
764 IF( kstep.EQ.2 ) THEN
765* (*) Make sure that diagonal element of pivot is real
766 a( k, k ) = dble( a( k, k ) )
767* (5) Swap row elements
768 t = a( k+1, k )
769 a( k+1, k ) = a( kp, k )
770 a( kp, k ) = t
771 END IF
772 ELSE
773* (*) Make sure that diagonal element of pivot is real
774 a( k, k ) = dble( a( k, k ) )
775 IF( kstep.EQ.2 )
776 $ a( k+1, k+1 ) = dble( a( k+1, k+1 ) )
777 END IF
778*
779* Update the trailing submatrix
780*
781 IF( kstep.EQ.1 ) THEN
782*
783* 1-by-1 pivot block D(k): column k of A now holds
784*
785* W(k) = L(k)*D(k),
786*
787* where L(k) is the k-th column of L
788*
789 IF( k.LT.n ) THEN
790*
791* Perform a rank-1 update of A(k+1:n,k+1:n) and
792* store L(k) in column k
793*
794* Handle division by a small number
795*
796 IF( abs( dble( a( k, k ) ) ).GE.sfmin ) THEN
797*
798* Perform a rank-1 update of A(k+1:n,k+1:n) as
799* A := A - L(k)*D(k)*L(k)**T
800* = A - W(k)*(1/D(k))*W(k)**T
801*
802 d11 = one / dble( a( k, k ) )
803 CALL zher( uplo, n-k, -d11, a( k+1, k ), 1,
804 $ a( k+1, k+1 ), lda )
805*
806* Store L(k) in column k
807*
808 CALL zdscal( n-k, d11, a( k+1, k ), 1 )
809 ELSE
810*
811* Store L(k) in column k
812*
813 d11 = dble( a( k, k ) )
814 DO 46 ii = k + 1, n
815 a( ii, k ) = a( ii, k ) / d11
816 46 CONTINUE
817*
818* Perform a rank-1 update of A(k+1:n,k+1:n) as
819* A := A - L(k)*D(k)*L(k)**T
820* = A - W(k)*(1/D(k))*W(k)**T
821* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
822*
823 CALL zher( uplo, n-k, -d11, a( k+1, k ), 1,
824 $ a( k+1, k+1 ), lda )
825 END IF
826 END IF
827*
828 ELSE
829*
830* 2-by-2 pivot block D(k): columns k and k+1 now hold
831*
832* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
833*
834* where L(k) and L(k+1) are the k-th and (k+1)-th columns
835* of L
836*
837*
838* Perform a rank-2 update of A(k+2:n,k+2:n) as
839*
840* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
841* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
842*
843* and store L(k) and L(k+1) in columns k and k+1
844*
845 IF( k.LT.n-1 ) THEN
846* D = |A21|
847 d = dlapy2( dble( a( k+1, k ) ),
848 $ dimag( a( k+1, k ) ) )
849 d11 = dble( a( k+1, k+1 ) ) / d
850 d22 = dble( a( k, k ) ) / d
851 d21 = a( k+1, k ) / d
852 tt = one / ( d11*d22-one )
853*
854 DO 60 j = k + 2, n
855*
856* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
857*
858 wk = tt*( d11*a( j, k )-d21*a( j, k+1 ) )
859 wkp1 = tt*( d22*a( j, k+1 )-dconjg( d21 )*
860 $ a( j, k ) )
861*
862* Perform a rank-2 update of A(k+2:n,k+2:n)
863*
864 DO 50 i = j, n
865 a( i, j ) = a( i, j ) -
866 $ ( a( i, k ) / d )*dconjg( wk ) -
867 $ ( a( i, k+1 ) / d )*dconjg( wkp1 )
868 50 CONTINUE
869*
870* Store L(k) and L(k+1) in cols k and k+1 for row J
871*
872 a( j, k ) = wk / d
873 a( j, k+1 ) = wkp1 / d
874* (*) Make sure that diagonal element of pivot is real
875 a( j, j ) = dcmplx( dble( a( j, j ) ), zero )
876*
877 60 CONTINUE
878*
879 END IF
880*
881 END IF
882*
883 END IF
884*
885* Store details of the interchanges in IPIV
886*
887 IF( kstep.EQ.1 ) THEN
888 ipiv( k ) = kp
889 ELSE
890 ipiv( k ) = -p
891 ipiv( k+1 ) = -kp
892 END IF
893*
894* Increase K and return to the start of the main loop
895*
896 k = k + kstep
897 GO TO 40
898*
899 END IF
900*
901 70 CONTINUE
902*
903 RETURN
904*
905* End of ZHETF2_ROOK
906*

◆ zhetrd()

subroutine zhetrd ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZHETRD

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

Purpose:
!>
!> ZHETRD reduces a complex Hermitian matrix A to real symmetric
!> tridiagonal form T by a unitary similarity transformation:
!> Q**H * A * Q = T.
!> 
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*16 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, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the unitary
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the unitary matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!> 
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!> 
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> 
[out]WORK
!>          WORK is COMPLEX*16 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.
!>          For optimum performance LWORK >= N*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.
Further Details:
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n-1) . . . H(2) H(1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
!>  A(1:i-1,i+1), and tau in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(n-1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
!>  and tau in TAU(i).
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  d   e   v2  v3  v4 )              (  d                  )
!>    (      d   e   v3  v4 )              (  e   d              )
!>    (          d   e   v4 )              (  v1  e   d          )
!>    (              d   e  )              (  v1  v2  e   d      )
!>    (                  d  )              (  v1  v2  v3  e   d  )
!>
!>  where d and e denote diagonal and off-diagonal elements of T, and vi
!>  denotes an element of the vector defining H(i).
!> 

Definition at line 191 of file zhetrd.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, LWORK, N
200* ..
201* .. Array Arguments ..
202 DOUBLE PRECISION D( * ), E( * )
203 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
204* ..
205*
206* =====================================================================
207*
208* .. Parameters ..
209 DOUBLE PRECISION ONE
210 parameter( one = 1.0d+0 )
211 COMPLEX*16 CONE
212 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
213* ..
214* .. Local Scalars ..
215 LOGICAL LQUERY, UPPER
216 INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
217 $ NBMIN, NX
218* ..
219* .. External Subroutines ..
220 EXTERNAL xerbla, zher2k, zhetd2, zlatrd
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC max
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 INTEGER ILAENV
228 EXTERNAL lsame, ilaenv
229* ..
230* .. Executable Statements ..
231*
232* Test the input parameters
233*
234 info = 0
235 upper = lsame( uplo, 'U' )
236 lquery = ( lwork.EQ.-1 )
237 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
238 info = -1
239 ELSE IF( n.LT.0 ) THEN
240 info = -2
241 ELSE IF( lda.LT.max( 1, n ) ) THEN
242 info = -4
243 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
244 info = -9
245 END IF
246*
247 IF( info.EQ.0 ) THEN
248*
249* Determine the block size.
250*
251 nb = ilaenv( 1, 'ZHETRD', uplo, n, -1, -1, -1 )
252 lwkopt = n*nb
253 work( 1 ) = lwkopt
254 END IF
255*
256 IF( info.NE.0 ) THEN
257 CALL xerbla( 'ZHETRD', -info )
258 RETURN
259 ELSE IF( lquery ) THEN
260 RETURN
261 END IF
262*
263* Quick return if possible
264*
265 IF( n.EQ.0 ) THEN
266 work( 1 ) = 1
267 RETURN
268 END IF
269*
270 nx = n
271 iws = 1
272 IF( nb.GT.1 .AND. nb.LT.n ) THEN
273*
274* Determine when to cross over from blocked to unblocked code
275* (last block is always handled by unblocked code).
276*
277 nx = max( nb, ilaenv( 3, 'ZHETRD', uplo, n, -1, -1, -1 ) )
278 IF( nx.LT.n ) THEN
279*
280* Determine if workspace is large enough for blocked code.
281*
282 ldwork = n
283 iws = ldwork*nb
284 IF( lwork.LT.iws ) THEN
285*
286* Not enough workspace to use optimal NB: determine the
287* minimum value of NB, and reduce NB or force use of
288* unblocked code by setting NX = N.
289*
290 nb = max( lwork / ldwork, 1 )
291 nbmin = ilaenv( 2, 'ZHETRD', uplo, n, -1, -1, -1 )
292 IF( nb.LT.nbmin )
293 $ nx = n
294 END IF
295 ELSE
296 nx = n
297 END IF
298 ELSE
299 nb = 1
300 END IF
301*
302 IF( upper ) THEN
303*
304* Reduce the upper triangle of A.
305* Columns 1:kk are handled by the unblocked method.
306*
307 kk = n - ( ( n-nx+nb-1 ) / nb )*nb
308 DO 20 i = n - nb + 1, kk + 1, -nb
309*
310* Reduce columns i:i+nb-1 to tridiagonal form and form the
311* matrix W which is needed to update the unreduced part of
312* the matrix
313*
314 CALL zlatrd( uplo, i+nb-1, nb, a, lda, e, tau, work,
315 $ ldwork )
316*
317* Update the unreduced submatrix A(1:i-1,1:i-1), using an
318* update of the form: A := A - V*W**H - W*V**H
319*
320 CALL zher2k( uplo, 'No transpose', i-1, nb, -cone,
321 $ a( 1, i ), lda, work, ldwork, one, a, lda )
322*
323* Copy superdiagonal elements back into A, and diagonal
324* elements into D
325*
326 DO 10 j = i, i + nb - 1
327 a( j-1, j ) = e( j-1 )
328 d( j ) = dble( a( j, j ) )
329 10 CONTINUE
330 20 CONTINUE
331*
332* Use unblocked code to reduce the last or only block
333*
334 CALL zhetd2( uplo, kk, a, lda, d, e, tau, iinfo )
335 ELSE
336*
337* Reduce the lower triangle of A
338*
339 DO 40 i = 1, n - nx, nb
340*
341* Reduce columns i:i+nb-1 to tridiagonal form and form the
342* matrix W which is needed to update the unreduced part of
343* the matrix
344*
345 CALL zlatrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),
346 $ tau( i ), work, ldwork )
347*
348* Update the unreduced submatrix A(i+nb:n,i+nb:n), using
349* an update of the form: A := A - V*W**H - W*V**H
350*
351 CALL zher2k( uplo, 'No transpose', n-i-nb+1, nb, -cone,
352 $ a( i+nb, i ), lda, work( nb+1 ), ldwork, one,
353 $ a( i+nb, i+nb ), lda )
354*
355* Copy subdiagonal elements back into A, and diagonal
356* elements into D
357*
358 DO 30 j = i, i + nb - 1
359 a( j+1, j ) = e( j )
360 d( j ) = dble( a( j, j ) )
361 30 CONTINUE
362 40 CONTINUE
363*
364* Use unblocked code to reduce the last or only block
365*
366 CALL zhetd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),
367 $ tau( i ), iinfo )
368 END IF
369*
370 work( 1 ) = lwkopt
371 RETURN
372*
373* End of ZHETRD
374*
subroutine zhetd2(uplo, n, a, lda, d, e, tau, info)
ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transfo...
Definition zhetd2.f:175
subroutine zlatrd(uplo, n, nb, a, lda, e, tau, w, ldw)
ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal fo...
Definition zlatrd.f:199

◆ zhetrd_2stage()

subroutine zhetrd_2stage ( character vect,
character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) hous2,
integer lhous2,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZHETRD_2STAGE

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

Purpose:
!>
!> ZHETRD_2STAGE reduces a complex Hermitian matrix A to real symmetric
!> tridiagonal form T by a unitary similarity transformation:
!> Q1**H Q2**H* A * Q2 * Q1 = T.
!> 
Parameters
[in]VECT
!>          VECT is CHARACTER*1
!>          = 'N':  No need for the Housholder representation, 
!>                  in particular for the second stage (Band to
!>                  tridiagonal) and thus LHOUS2 is of size max(1, 4*N);
!>          = 'V':  the Householder representation is needed to 
!>                  either generate Q1 Q2 or to apply Q1 Q2, 
!>                  then LHOUS2 is to be queried and computed.
!>                  (NOT AVAILABLE IN THIS RELEASE).
!> 
[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*16 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, if UPLO = 'U', the band superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          internal band-diagonal matrix AB, and the elements above 
!>          the KD superdiagonal, with the array TAU, represent the unitary
!>          matrix Q1 as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and band subdiagonal of A are over-
!>          written by the corresponding elements of the internal band-diagonal
!>          matrix AB, and the elements below the KD subdiagonal, with
!>          the array TAU, represent the unitary matrix Q1 as a product
!>          of elementary reflectors. See Further Details.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!> 
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T.
!> 
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors of 
!>          the first stage (see Further Details).
!> 
[out]HOUS2
!>          HOUS2 is COMPLEX*16 array, dimension (LHOUS2)
!>          Stores the Householder representation of the stage2
!>          band to tridiagonal.
!> 
[in]LHOUS2
!>          LHOUS2 is INTEGER
!>          The dimension of the array HOUS2.
!>          If LWORK = -1, or LHOUS2 = -1,
!>          then a query is assumed; the routine
!>          only calculates the optimal size of the HOUS2 array, returns
!>          this value as the first entry of the HOUS2 array, and no error
!>          message related to LHOUS2 is issued by XERBLA.
!>          If VECT='N', LHOUS2 = max(1, 4*n);
!>          if VECT='V', option not yet available.
!> 
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!> 
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK = MAX(1, dimension)
!>          If LWORK = -1, or LHOUS2=-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.
!>          LWORK = MAX(1, dimension) where
!>          dimension   = max(stage1,stage2) + (KD+1)*N
!>                      = N*KD + N*max(KD+1,FACTOPTNB) 
!>                        + max(2*KD*KD, KD*NTHREADS) 
!>                        + (KD+1)*N 
!>          where KD is the blocking size of the reduction,
!>          FACTOPTNB is the blocking used by the QR or LQ
!>          algorithm, usually FACTOPTNB=128 is a good choice
!>          NTHREADS is the number of threads used when
!>          openMP compilation is enabled, otherwise =1.
!> 
[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.
Further Details:
!>
!>  Implemented by Azzam Haidar.
!>
!>  All details are available on technical report, SC11, SC13 papers.
!>
!>  Azzam Haidar, Hatem Ltaief, and Jack Dongarra.
!>  Parallel reduction to condensed forms for symmetric eigenvalue problems
!>  using aggregated fine-grained and memory-aware kernels. In Proceedings
!>  of 2011 International Conference for High Performance Computing,
!>  Networking, Storage and Analysis (SC '11), New York, NY, USA,
!>  Article 8 , 11 pages.
!>  http://doi.acm.org/10.1145/2063384.2063394
!>
!>  A. Haidar, J. Kurzak, P. Luszczek, 2013.
!>  An improved parallel singular value algorithm and its implementation 
!>  for multicore hardware, In Proceedings of 2013 International Conference
!>  for High Performance Computing, Networking, Storage and Analysis (SC '13).
!>  Denver, Colorado, USA, 2013.
!>  Article 90, 12 pages.
!>  http://doi.acm.org/10.1145/2503210.2503292
!>
!>  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra.
!>  A novel hybrid CPU-GPU generalized eigensolver for electronic structure 
!>  calculations based on fine-grained memory aware tasks.
!>  International Journal of High Performance Computing Applications.
!>  Volume 28 Issue 2, Pages 196-209, May 2014.
!>  http://hpc.sagepub.com/content/28/2/196 
!>
!> 

Definition at line 222 of file zhetrd_2stage.f.

224*
225 IMPLICIT NONE
226*
227* -- LAPACK computational routine --
228* -- LAPACK is a software package provided by Univ. of Tennessee, --
229* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
230*
231* .. Scalar Arguments ..
232 CHARACTER VECT, UPLO
233 INTEGER N, LDA, LWORK, LHOUS2, INFO
234* ..
235* .. Array Arguments ..
236 DOUBLE PRECISION D( * ), E( * )
237 COMPLEX*16 A( LDA, * ), TAU( * ),
238 $ HOUS2( * ), WORK( * )
239* ..
240*
241* =====================================================================
242* ..
243* .. Local Scalars ..
244 LOGICAL LQUERY, UPPER, WANTQ
245 INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS
246* ..
247* .. External Subroutines ..
249* ..
250* .. External Functions ..
251 LOGICAL LSAME
252 INTEGER ILAENV2STAGE
253 EXTERNAL lsame, ilaenv2stage
254* ..
255* .. Executable Statements ..
256*
257* Test the input parameters
258*
259 info = 0
260 wantq = lsame( vect, 'V' )
261 upper = lsame( uplo, 'U' )
262 lquery = ( lwork.EQ.-1 ) .OR. ( lhous2.EQ.-1 )
263*
264* Determine the block size, the workspace size and the hous size.
265*
266 kd = ilaenv2stage( 1, 'ZHETRD_2STAGE', vect, n, -1, -1, -1 )
267 ib = ilaenv2stage( 2, 'ZHETRD_2STAGE', vect, n, kd, -1, -1 )
268 lhmin = ilaenv2stage( 3, 'ZHETRD_2STAGE', vect, n, kd, ib, -1 )
269 lwmin = ilaenv2stage( 4, 'ZHETRD_2STAGE', vect, n, kd, ib, -1 )
270* WRITE(*,*),'ZHETRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO,
271* $ LHMIN, LWMIN
272*
273 IF( .NOT.lsame( vect, 'N' ) ) THEN
274 info = -1
275 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
276 info = -2
277 ELSE IF( n.LT.0 ) THEN
278 info = -3
279 ELSE IF( lda.LT.max( 1, n ) ) THEN
280 info = -5
281 ELSE IF( lhous2.LT.lhmin .AND. .NOT.lquery ) THEN
282 info = -10
283 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
284 info = -12
285 END IF
286*
287 IF( info.EQ.0 ) THEN
288 hous2( 1 ) = lhmin
289 work( 1 ) = lwmin
290 END IF
291*
292 IF( info.NE.0 ) THEN
293 CALL xerbla( 'ZHETRD_2STAGE', -info )
294 RETURN
295 ELSE IF( lquery ) THEN
296 RETURN
297 END IF
298*
299* Quick return if possible
300*
301 IF( n.EQ.0 ) THEN
302 work( 1 ) = 1
303 RETURN
304 END IF
305*
306* Determine pointer position
307*
308 ldab = kd+1
309 lwrk = lwork-ldab*n
310 abpos = 1
311 wpos = abpos + ldab*n
312 CALL zhetrd_he2hb( uplo, n, kd, a, lda, work( abpos ), ldab,
313 $ tau, work( wpos ), lwrk, info )
314 IF( info.NE.0 ) THEN
315 CALL xerbla( 'ZHETRD_HE2HB', -info )
316 RETURN
317 END IF
318 CALL zhetrd_hb2st( 'Y', vect, uplo, n, kd,
319 $ work( abpos ), ldab, d, e,
320 $ hous2, lhous2, work( wpos ), lwrk, info )
321 IF( info.NE.0 ) THEN
322 CALL xerbla( 'ZHETRD_HB2ST', -info )
323 RETURN
324 END IF
325*
326*
327 hous2( 1 ) = lhmin
328 work( 1 ) = lwmin
329 RETURN
330*
331* End of ZHETRD_2STAGE
332*
integer function ilaenv2stage(ispec, name, opts, n1, n2, n3, n4)
ILAENV2STAGE
subroutine zhetrd_he2hb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
ZHETRD_HE2HB
subroutine zhetrd_hb2st(stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T

◆ zhetrd_he2hb()

subroutine zhetrd_he2hb ( character uplo,
integer n,
integer kd,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZHETRD_HE2HB

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

Purpose:
!>
!> ZHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian
!> band-diagonal form AB by a unitary similarity transformation:
!> Q**H * A * Q = AB.
!> 
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]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the reduced matrix if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!>          The reduced matrix is stored in the array AB.
!> 
[in,out]A
!>          A is COMPLEX*16 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, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the unitary
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the unitary matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[out]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          On exit, the upper or lower triangle of the Hermitian band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!> 
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!> 
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> 
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>          On exit, if INFO = 0, or if LWORK=-1, 
!>          WORK(1) returns the size of LWORK.
!> 
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK which should be calculated
!>          by a workspace query. LWORK = MAX(1, LWORK_QUERY)
!>          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.
!>          LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD
!>          where FACTOPTNB is the blocking used by the QR or LQ
!>          algorithm, usually FACTOPTNB=128 is a good choice otherwise
!>          putting LWORK=-1 will provide the size of WORK.
!> 
[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.
Further Details:
!>
!>  Implemented by Azzam Haidar.
!>
!>  All details are available on technical report, SC11, SC13 papers.
!>
!>  Azzam Haidar, Hatem Ltaief, and Jack Dongarra.
!>  Parallel reduction to condensed forms for symmetric eigenvalue problems
!>  using aggregated fine-grained and memory-aware kernels. In Proceedings
!>  of 2011 International Conference for High Performance Computing,
!>  Networking, Storage and Analysis (SC '11), New York, NY, USA,
!>  Article 8 , 11 pages.
!>  http://doi.acm.org/10.1145/2063384.2063394
!>
!>  A. Haidar, J. Kurzak, P. Luszczek, 2013.
!>  An improved parallel singular value algorithm and its implementation 
!>  for multicore hardware, In Proceedings of 2013 International Conference
!>  for High Performance Computing, Networking, Storage and Analysis (SC '13).
!>  Denver, Colorado, USA, 2013.
!>  Article 90, 12 pages.
!>  http://doi.acm.org/10.1145/2503210.2503292
!>
!>  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra.
!>  A novel hybrid CPU-GPU generalized eigensolver for electronic structure 
!>  calculations based on fine-grained memory aware tasks.
!>  International Journal of High Performance Computing Applications.
!>  Volume 28 Issue 2, Pages 196-209, May 2014.
!>  http://hpc.sagepub.com/content/28/2/196 
!>
!> 
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(k)**H . . . H(2)**H H(1)**H, where k = n-kd.
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in
!>  A(i,i+kd+1:n), and tau in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = n-kd.
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in
!>  A(i+kd+2:n,i), and tau in TAU(i).
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  ab  ab/v1  v1      v1     v1    )              (  ab                            )
!>    (      ab     ab/v2   v2     v2    )              (  ab/v1  ab                     )
!>    (             ab      ab/v3  v3    )              (  v1     ab/v2  ab              )
!>    (                     ab     ab/v4 )              (  v1     v2     ab/v3  ab       )
!>    (                            ab    )              (  v1     v2     v3     ab/v4 ab )
!>
!>  where d and e denote diagonal and off-diagonal elements of T, and vi
!>  denotes an element of the vector defining H(i).
!> 

Definition at line 241 of file zhetrd_he2hb.f.

243*
244 IMPLICIT NONE
245*
246* -- LAPACK computational routine --
247* -- LAPACK is a software package provided by Univ. of Tennessee, --
248* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
249*
250* .. Scalar Arguments ..
251 CHARACTER UPLO
252 INTEGER INFO, LDA, LDAB, LWORK, N, KD
253* ..
254* .. Array Arguments ..
255 COMPLEX*16 A( LDA, * ), AB( LDAB, * ),
256 $ TAU( * ), WORK( * )
257* ..
258*
259* =====================================================================
260*
261* .. Parameters ..
262 DOUBLE PRECISION RONE
263 COMPLEX*16 ZERO, ONE, HALF
264 parameter( rone = 1.0d+0,
265 $ zero = ( 0.0d+0, 0.0d+0 ),
266 $ one = ( 1.0d+0, 0.0d+0 ),
267 $ half = ( 0.5d+0, 0.0d+0 ) )
268* ..
269* .. Local Scalars ..
270 LOGICAL LQUERY, UPPER
271 INTEGER I, J, IINFO, LWMIN, PN, PK, LK,
272 $ LDT, LDW, LDS2, LDS1,
273 $ LS2, LS1, LW, LT,
274 $ TPOS, WPOS, S2POS, S1POS
275* ..
276* .. External Subroutines ..
277 EXTERNAL xerbla, zher2k, zhemm, zgemm, zcopy,
279* ..
280* .. Intrinsic Functions ..
281 INTRINSIC min, max
282* ..
283* .. External Functions ..
284 LOGICAL LSAME
285 INTEGER ILAENV2STAGE
286 EXTERNAL lsame, ilaenv2stage
287* ..
288* .. Executable Statements ..
289*
290* Determine the minimal workspace size required
291* and test the input parameters
292*
293 info = 0
294 upper = lsame( uplo, 'U' )
295 lquery = ( lwork.EQ.-1 )
296 lwmin = ilaenv2stage( 4, 'ZHETRD_HE2HB', '', n, kd, -1, -1 )
297
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( kd.LT.0 ) THEN
303 info = -3
304 ELSE IF( lda.LT.max( 1, n ) ) THEN
305 info = -5
306 ELSE IF( ldab.LT.max( 1, kd+1 ) ) THEN
307 info = -7
308 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
309 info = -10
310 END IF
311*
312 IF( info.NE.0 ) THEN
313 CALL xerbla( 'ZHETRD_HE2HB', -info )
314 RETURN
315 ELSE IF( lquery ) THEN
316 work( 1 ) = lwmin
317 RETURN
318 END IF
319*
320* Quick return if possible
321* Copy the upper/lower portion of A into AB
322*
323 IF( n.LE.kd+1 ) THEN
324 IF( upper ) THEN
325 DO 100 i = 1, n
326 lk = min( kd+1, i )
327 CALL zcopy( lk, a( i-lk+1, i ), 1,
328 $ ab( kd+1-lk+1, i ), 1 )
329 100 CONTINUE
330 ELSE
331 DO 110 i = 1, n
332 lk = min( kd+1, n-i+1 )
333 CALL zcopy( lk, a( i, i ), 1, ab( 1, i ), 1 )
334 110 CONTINUE
335 ENDIF
336 work( 1 ) = 1
337 RETURN
338 END IF
339*
340* Determine the pointer position for the workspace
341*
342 ldt = kd
343 lds1 = kd
344 lt = ldt*kd
345 lw = n*kd
346 ls1 = lds1*kd
347 ls2 = lwmin - lt - lw - ls1
348* LS2 = N*MAX(KD,FACTOPTNB)
349 tpos = 1
350 wpos = tpos + lt
351 s1pos = wpos + lw
352 s2pos = s1pos + ls1
353 IF( upper ) THEN
354 ldw = kd
355 lds2 = kd
356 ELSE
357 ldw = n
358 lds2 = n
359 ENDIF
360*
361*
362* Set the workspace of the triangular matrix T to zero once such a
363* way every time T is generated the upper/lower portion will be always zero
364*
365 CALL zlaset( "A", ldt, kd, zero, zero, work( tpos ), ldt )
366*
367 IF( upper ) THEN
368 DO 10 i = 1, n - kd, kd
369 pn = n-i-kd+1
370 pk = min( n-i-kd+1, kd )
371*
372* Compute the LQ factorization of the current block
373*
374 CALL zgelqf( kd, pn, a( i, i+kd ), lda,
375 $ tau( i ), work( s2pos ), ls2, iinfo )
376*
377* Copy the upper portion of A into AB
378*
379 DO 20 j = i, i+pk-1
380 lk = min( kd, n-j ) + 1
381 CALL zcopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
382 20 CONTINUE
383*
384 CALL zlaset( 'Lower', pk, pk, zero, one,
385 $ a( i, i+kd ), lda )
386*
387* Form the matrix T
388*
389 CALL zlarft( 'Forward', 'Rowwise', pn, pk,
390 $ a( i, i+kd ), lda, tau( i ),
391 $ work( tpos ), ldt )
392*
393* Compute W:
394*
395 CALL zgemm( 'Conjugate', 'No transpose', pk, pn, pk,
396 $ one, work( tpos ), ldt,
397 $ a( i, i+kd ), lda,
398 $ zero, work( s2pos ), lds2 )
399*
400 CALL zhemm( 'Right', uplo, pk, pn,
401 $ one, a( i+kd, i+kd ), lda,
402 $ work( s2pos ), lds2,
403 $ zero, work( wpos ), ldw )
404*
405 CALL zgemm( 'No transpose', 'Conjugate', pk, pk, pn,
406 $ one, work( wpos ), ldw,
407 $ work( s2pos ), lds2,
408 $ zero, work( s1pos ), lds1 )
409*
410 CALL zgemm( 'No transpose', 'No transpose', pk, pn, pk,
411 $ -half, work( s1pos ), lds1,
412 $ a( i, i+kd ), lda,
413 $ one, work( wpos ), ldw )
414*
415*
416* Update the unreduced submatrix A(i+kd:n,i+kd:n), using
417* an update of the form: A := A - V'*W - W'*V
418*
419 CALL zher2k( uplo, 'Conjugate', pn, pk,
420 $ -one, a( i, i+kd ), lda,
421 $ work( wpos ), ldw,
422 $ rone, a( i+kd, i+kd ), lda )
423 10 CONTINUE
424*
425* Copy the upper band to AB which is the band storage matrix
426*
427 DO 30 j = n-kd+1, n
428 lk = min(kd, n-j) + 1
429 CALL zcopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
430 30 CONTINUE
431*
432 ELSE
433*
434* Reduce the lower triangle of A to lower band matrix
435*
436 DO 40 i = 1, n - kd, kd
437 pn = n-i-kd+1
438 pk = min( n-i-kd+1, kd )
439*
440* Compute the QR factorization of the current block
441*
442 CALL zgeqrf( pn, kd, a( i+kd, i ), lda,
443 $ tau( i ), work( s2pos ), ls2, iinfo )
444*
445* Copy the upper portion of A into AB
446*
447 DO 50 j = i, i+pk-1
448 lk = min( kd, n-j ) + 1
449 CALL zcopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
450 50 CONTINUE
451*
452 CALL zlaset( 'Upper', pk, pk, zero, one,
453 $ a( i+kd, i ), lda )
454*
455* Form the matrix T
456*
457 CALL zlarft( 'Forward', 'Columnwise', pn, pk,
458 $ a( i+kd, i ), lda, tau( i ),
459 $ work( tpos ), ldt )
460*
461* Compute W:
462*
463 CALL zgemm( 'No transpose', 'No transpose', pn, pk, pk,
464 $ one, a( i+kd, i ), lda,
465 $ work( tpos ), ldt,
466 $ zero, work( s2pos ), lds2 )
467*
468 CALL zhemm( 'Left', uplo, pn, pk,
469 $ one, a( i+kd, i+kd ), lda,
470 $ work( s2pos ), lds2,
471 $ zero, work( wpos ), ldw )
472*
473 CALL zgemm( 'Conjugate', 'No transpose', pk, pk, pn,
474 $ one, work( s2pos ), lds2,
475 $ work( wpos ), ldw,
476 $ zero, work( s1pos ), lds1 )
477*
478 CALL zgemm( 'No transpose', 'No transpose', pn, pk, pk,
479 $ -half, a( i+kd, i ), lda,
480 $ work( s1pos ), lds1,
481 $ one, work( wpos ), ldw )
482*
483*
484* Update the unreduced submatrix A(i+kd:n,i+kd:n), using
485* an update of the form: A := A - V*W' - W*V'
486*
487 CALL zher2k( uplo, 'No transpose', pn, pk,
488 $ -one, a( i+kd, i ), lda,
489 $ work( wpos ), ldw,
490 $ rone, a( i+kd, i+kd ), lda )
491* ==================================================================
492* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED
493* DO 45 J = I, I+PK-1
494* LK = MIN( KD, N-J ) + 1
495* CALL ZCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 )
496* 45 CONTINUE
497* ==================================================================
498 40 CONTINUE
499*
500* Copy the lower band to AB which is the band storage matrix
501*
502 DO 60 j = n-kd+1, n
503 lk = min(kd, n-j) + 1
504 CALL zcopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
505 60 CONTINUE
506
507 END IF
508*
509 work( 1 ) = lwmin
510 RETURN
511*
512* End of ZHETRD_HE2HB
513*
subroutine zgelqf(m, n, a, lda, tau, work, lwork, info)
ZGELQF
Definition zgelqf.f:143
subroutine zlarft(direct, storev, n, k, v, ldv, tau, t, ldt)
ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition zlarft.f:163
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:106
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
subroutine zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
Definition zgeqrf.f:151

◆ zhetrf()

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

ZHETRF

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

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

◆ zhetrf_aa()

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

ZHETRF_AA

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

Purpose:
!>
!> ZHETRF_AA computes the factorization of a complex hermitian matrix A
!> using the Aasen's algorithm.  The form of the factorization is
!>
!>    A = U**H*T*U  or  A = L*T*L**H
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is a hermitian 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*16 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, 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*16 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 zhetrf_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*16 A( LDA, * ), WORK( * )
146* ..
147*
148* =====================================================================
149* .. Parameters ..
150 COMPLEX*16 ZERO, ONE
151 parameter( zero = (0.0d+0, 0.0d+0), one = (1.0d+0, 0.0d+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*16 ALPHA
158* ..
159* .. External Functions ..
160 LOGICAL LSAME
161 INTEGER ILAENV
162 EXTERNAL lsame, ilaenv
163* ..
164* .. External Subroutines ..
166* ..
167* .. Intrinsic Functions ..
168 INTRINSIC dble, dconjg, max
169* ..
170* .. Executable Statements ..
171*
172* Determine the block size
173*
174 nb = ilaenv( 1, 'ZHETRF_AA', uplo, n, -1, -1, -1 )
175*
176* Test the input parameters.
177*
178 info = 0
179 upper = lsame( uplo, 'U' )
180 lquery = ( lwork.EQ.-1 )
181 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
182 info = -1
183 ELSE IF( n.LT.0 ) THEN
184 info = -2
185 ELSE IF( lda.LT.max( 1, n ) ) THEN
186 info = -4
187 ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN
188 info = -7
189 END IF
190*
191 IF( info.EQ.0 ) THEN
192 lwkopt = (nb+1)*n
193 work( 1 ) = lwkopt
194 END IF
195*
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'ZHETRF_AA', -info )
198 RETURN
199 ELSE IF( lquery ) THEN
200 RETURN
201 END IF
202*
203* Quick return
204*
205 IF ( n.EQ.0 ) THEN
206 RETURN
207 ENDIF
208 ipiv( 1 ) = 1
209 IF ( n.EQ.1 ) THEN
210 a( 1, 1 ) = dble( a( 1, 1 ) )
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**H*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 zcopy( 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 ZLAHEF;
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 zlahef_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 zswap( 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 the 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 = dconjg( a( j, j+1 ) )
280 a( j, j+1 ) = one
281 CALL zcopy( n-j, a( j-1, j+1 ), lda,
282 $ work( (j+1-j1+1)+jb*n ), 1 )
283 CALL zscal( 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=0 and K2=1 for the first panel,
287* and K1=1 and K2=0 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 ZGEMV
309*
310 j3 = j2
311 DO mj = nj-1, 1, -1
312 CALL zgemm( 'Conjugate transpose', 'Transpose',
313 $ 1, mj, jb+1,
314 $ -one, a( j1-k2, j3 ), lda,
315 $ work( (j3-j1+1)+k1*n ), n,
316 $ one, a( j3, j3 ), lda )
317 j3 = j3 + 1
318 END DO
319*
320* Update off-diagonal block of J2-th block row with ZGEMM
321*
322 CALL zgemm( 'Conjugate transpose', 'Transpose',
323 $ nj, n-j3+1, jb+1,
324 $ -one, a( j1-k2, j2 ), lda,
325 $ work( (j3-j1+1)+k1*n ), n,
326 $ one, a( j2, j3 ), lda )
327 END DO
328*
329* Recover T( J, J+1 )
330*
331 a( j, j+1 ) = dconjg( alpha )
332 END IF
333*
334* WORK(J+1, 1) stores H(J+1, 1)
335*
336 CALL zcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 )
337 END IF
338 GO TO 10
339 ELSE
340*
341* .....................................................
342* Factorize A as L*D*L**H using the lower triangle of A
343* .....................................................
344*
345* copy first column A(1:N, 1) into H(1:N, 1)
346* (stored in WORK(1:N))
347*
348 CALL zcopy( n, a( 1, 1 ), 1, work( 1 ), 1 )
349*
350* J is the main loop index, increasing from 1 to N in steps of
351* JB, where JB is the number of columns factorized by ZLAHEF;
352* JB is either NB, or N-J+1 for the last block
353*
354 j = 0
355 11 CONTINUE
356 IF( j.GE.n )
357 $ GO TO 20
358*
359* each step of the main loop
360* J is the last column of the previous panel
361* J1 is the first column of the current panel
362* K1 identifies if the previous column of the panel has been
363* explicitly stored, e.g., K1=1 for the first panel, and
364* K1=0 for the rest
365*
366 j1 = j+1
367 jb = min( n-j1+1, nb )
368 k1 = max(1, j)-j
369*
370* Panel factorization
371*
372 CALL zlahef_aa( uplo, 2-k1, n-j, jb,
373 $ a( j+1, max(1, j) ), lda,
374 $ ipiv( j+1 ), work, n, work( n*nb+1 ) )
375*
376* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot)
377*
378 DO j2 = j+2, min(n, j+jb+1)
379 ipiv( j2 ) = ipiv( j2 ) + j
380 IF( (j2.NE.ipiv(j2)) .AND. ((j1-k1).GT.2) ) THEN
381 CALL zswap( j1-k1-2, a( j2, 1 ), lda,
382 $ a( ipiv(j2), 1 ), lda )
383 END IF
384 END DO
385 j = j + jb
386*
387* Trailing submatrix update, where
388* A(J2+1, J1-1) stores L(J2+1, J1) and
389* WORK(J2+1, 1) stores H(J2+1, 1)
390*
391 IF( j.LT.n ) THEN
392*
393* if the first panel and JB=1 (NB=1), then nothing to do
394*
395 IF( j1.GT.1 .OR. jb.GT.1 ) THEN
396*
397* Merge rank-1 update with BLAS-3 update
398*
399 alpha = dconjg( a( j+1, j ) )
400 a( j+1, j ) = one
401 CALL zcopy( n-j, a( j+1, j-1 ), 1,
402 $ work( (j+1-j1+1)+jb*n ), 1 )
403 CALL zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
404*
405* K1 identifies if the previous column of the panel has been
406* explicitly stored, e.g., K1=0 and K2=1 for the first panel,
407* and K1=1 and K2=0 for the rest
408*
409 IF( j1.GT.1 ) THEN
410*
411* Not first panel
412*
413 k2 = 1
414 ELSE
415*
416* First panel
417*
418 k2 = 0
419*
420* First update skips the first column
421*
422 jb = jb - 1
423 END IF
424*
425 DO j2 = j+1, n, nb
426 nj = min( nb, n-j2+1 )
427*
428* Update (J2, J2) diagonal block with ZGEMV
429*
430 j3 = j2
431 DO mj = nj-1, 1, -1
432 CALL zgemm( 'No transpose', 'Conjugate transpose',
433 $ mj, 1, jb+1,
434 $ -one, work( (j3-j1+1)+k1*n ), n,
435 $ a( j3, j1-k2 ), lda,
436 $ one, a( j3, j3 ), lda )
437 j3 = j3 + 1
438 END DO
439*
440* Update off-diagonal block of J2-th block column with ZGEMM
441*
442 CALL zgemm( 'No transpose', 'Conjugate transpose',
443 $ n-j3+1, nj, jb+1,
444 $ -one, work( (j3-j1+1)+k1*n ), n,
445 $ a( j2, j1-k2 ), lda,
446 $ one, a( j3, j2 ), lda )
447 END DO
448*
449* Recover T( J+1, J )
450*
451 a( j+1, j ) = dconjg( alpha )
452 END IF
453*
454* WORK(J+1, 1) stores H(J+1, 1)
455*
456 CALL zcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 )
457 END IF
458 GO TO 11
459 END IF
460*
461 20 CONTINUE
462 work( 1 ) = lwkopt
463 RETURN
464*
465* End of ZHETRF_AA
466*
subroutine zlahef_aa(uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
ZLAHEF_AA
Definition zlahef_aa.f:144
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158

◆ zhetrf_rk()

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

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

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

Purpose:
!> ZHETRF_RK computes the factorization of a complex Hermitian matrix A
!> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!>
!>    A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**H (or L**H) is the conjugate of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is Hermitian 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
!>          Hermitian 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*16 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, contains:
!>            a) ONLY diagonal elements of the Hermitian 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*16 array, dimension (N)
!>          On exit, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian 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 Hermitian 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*16 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 zhetrf_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*16 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 zlahef_rk, zhetf2_rk, zswap, 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, 'ZHETRF_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( 'ZHETRF_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, 'ZHETRF_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 ZLAHEF_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 zlahef_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 zhetf2_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 zswap( 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 ZLAHEF_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 zlahef_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 zhetf2_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 zswap( 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 ZHETRF_RK
494*
subroutine zlahef_rk(uplo, n, nb, kb, a, lda, e, ipiv, w, ldw, info)
ZLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bounded Bun...
Definition zlahef_rk.f:262
subroutine zhetf2_rk(uplo, n, a, lda, e, ipiv, info)
ZHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
Definition zhetf2_rk.f:241

◆ zhetrf_rook()

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

ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).

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

Purpose:
!>
!> ZHETRF_ROOK computes the factorization of a complex Hermitian 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 Hermitian 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*16 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, 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':
!>             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]WORK
!>          WORK is COMPLEX*16 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 211 of file zhetrf_rook.f.

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

◆ zhetri()

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

ZHETRI

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

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

Definition at line 113 of file zhetri.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*16 A( LDA, * ), WORK( * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 DOUBLE PRECISION ONE
132 COMPLEX*16 CONE, ZERO
133 parameter( one = 1.0d+0, cone = ( 1.0d+0, 0.0d+0 ),
134 $ zero = ( 0.0d+0, 0.0d+0 ) )
135* ..
136* .. Local Scalars ..
137 LOGICAL UPPER
138 INTEGER J, K, KP, KSTEP
139 DOUBLE PRECISION AK, AKP1, D, T
140 COMPLEX*16 AKKP1, TEMP
141* ..
142* .. External Functions ..
143 LOGICAL LSAME
144 COMPLEX*16 ZDOTC
145 EXTERNAL lsame, zdotc
146* ..
147* .. External Subroutines ..
148 EXTERNAL xerbla, zcopy, zhemv, zswap
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC abs, dble, dconjg, max
152* ..
153* .. Executable Statements ..
154*
155* Test the input parameters.
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( lda.LT.max( 1, n ) ) THEN
164 info = -4
165 END IF
166 IF( info.NE.0 ) THEN
167 CALL xerbla( 'ZHETRI', -info )
168 RETURN
169 END IF
170*
171* Quick return if possible
172*
173 IF( n.EQ.0 )
174 $ RETURN
175*
176* Check that the diagonal matrix D is nonsingular.
177*
178 IF( upper ) THEN
179*
180* Upper triangular storage: examine D from bottom to top
181*
182 DO 10 info = n, 1, -1
183 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
184 $ RETURN
185 10 CONTINUE
186 ELSE
187*
188* Lower triangular storage: examine D from top to bottom.
189*
190 DO 20 info = 1, n
191 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
192 $ RETURN
193 20 CONTINUE
194 END IF
195 info = 0
196*
197 IF( upper ) THEN
198*
199* Compute inv(A) from the factorization A = U*D*U**H.
200*
201* K is the main loop index, increasing from 1 to N in steps of
202* 1 or 2, depending on the size of the diagonal blocks.
203*
204 k = 1
205 30 CONTINUE
206*
207* If K > N, exit from loop.
208*
209 IF( k.GT.n )
210 $ GO TO 50
211*
212 IF( ipiv( k ).GT.0 ) THEN
213*
214* 1 x 1 diagonal block
215*
216* Invert the diagonal block.
217*
218 a( k, k ) = one / dble( a( k, k ) )
219*
220* Compute column K of the inverse.
221*
222 IF( k.GT.1 ) THEN
223 CALL zcopy( k-1, a( 1, k ), 1, work, 1 )
224 CALL zhemv( uplo, k-1, -cone, a, lda, work, 1, zero,
225 $ a( 1, k ), 1 )
226 a( k, k ) = a( k, k ) - dble( zdotc( k-1, work, 1, a( 1,
227 $ k ), 1 ) )
228 END IF
229 kstep = 1
230 ELSE
231*
232* 2 x 2 diagonal block
233*
234* Invert the diagonal block.
235*
236 t = abs( a( k, k+1 ) )
237 ak = dble( a( k, k ) ) / t
238 akp1 = dble( a( k+1, k+1 ) ) / t
239 akkp1 = a( k, k+1 ) / t
240 d = t*( ak*akp1-one )
241 a( k, k ) = akp1 / d
242 a( k+1, k+1 ) = ak / d
243 a( k, k+1 ) = -akkp1 / d
244*
245* Compute columns K and K+1 of the inverse.
246*
247 IF( k.GT.1 ) THEN
248 CALL zcopy( k-1, a( 1, k ), 1, work, 1 )
249 CALL zhemv( uplo, k-1, -cone, a, lda, work, 1, zero,
250 $ a( 1, k ), 1 )
251 a( k, k ) = a( k, k ) - dble( zdotc( k-1, work, 1, a( 1,
252 $ k ), 1 ) )
253 a( k, k+1 ) = a( k, k+1 ) -
254 $ zdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
255 CALL zcopy( k-1, a( 1, k+1 ), 1, work, 1 )
256 CALL zhemv( uplo, k-1, -cone, a, lda, work, 1, zero,
257 $ a( 1, k+1 ), 1 )
258 a( k+1, k+1 ) = a( k+1, k+1 ) -
259 $ dble( zdotc( k-1, work, 1, a( 1, k+1 ),
260 $ 1 ) )
261 END IF
262 kstep = 2
263 END IF
264*
265 kp = abs( ipiv( k ) )
266 IF( kp.NE.k ) THEN
267*
268* Interchange rows and columns K and KP in the leading
269* submatrix A(1:k+1,1:k+1)
270*
271 CALL zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
272 DO 40 j = kp + 1, k - 1
273 temp = dconjg( a( j, k ) )
274 a( j, k ) = dconjg( a( kp, j ) )
275 a( kp, j ) = temp
276 40 CONTINUE
277 a( kp, k ) = dconjg( a( kp, k ) )
278 temp = a( k, k )
279 a( k, k ) = a( kp, kp )
280 a( kp, kp ) = temp
281 IF( kstep.EQ.2 ) THEN
282 temp = a( k, k+1 )
283 a( k, k+1 ) = a( kp, k+1 )
284 a( kp, k+1 ) = temp
285 END IF
286 END IF
287*
288 k = k + kstep
289 GO TO 30
290 50 CONTINUE
291*
292 ELSE
293*
294* Compute inv(A) from the factorization A = L*D*L**H.
295*
296* K is the main loop index, increasing from 1 to N in steps of
297* 1 or 2, depending on the size of the diagonal blocks.
298*
299 k = n
300 60 CONTINUE
301*
302* If K < 1, exit from loop.
303*
304 IF( k.LT.1 )
305 $ GO TO 80
306*
307 IF( ipiv( k ).GT.0 ) THEN
308*
309* 1 x 1 diagonal block
310*
311* Invert the diagonal block.
312*
313 a( k, k ) = one / dble( a( k, k ) )
314*
315* Compute column K of the inverse.
316*
317 IF( k.LT.n ) THEN
318 CALL zcopy( n-k, a( k+1, k ), 1, work, 1 )
319 CALL zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
320 $ 1, zero, a( k+1, k ), 1 )
321 a( k, k ) = a( k, k ) - dble( zdotc( n-k, work, 1,
322 $ a( k+1, k ), 1 ) )
323 END IF
324 kstep = 1
325 ELSE
326*
327* 2 x 2 diagonal block
328*
329* Invert the diagonal block.
330*
331 t = abs( a( k, k-1 ) )
332 ak = dble( a( k-1, k-1 ) ) / t
333 akp1 = dble( a( k, k ) ) / t
334 akkp1 = a( k, k-1 ) / t
335 d = t*( ak*akp1-one )
336 a( k-1, k-1 ) = akp1 / d
337 a( k, k ) = ak / d
338 a( k, k-1 ) = -akkp1 / d
339*
340* Compute columns K-1 and K of the inverse.
341*
342 IF( k.LT.n ) THEN
343 CALL zcopy( n-k, a( k+1, k ), 1, work, 1 )
344 CALL zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
345 $ 1, zero, a( k+1, k ), 1 )
346 a( k, k ) = a( k, k ) - dble( zdotc( n-k, work, 1,
347 $ a( k+1, k ), 1 ) )
348 a( k, k-1 ) = a( k, k-1 ) -
349 $ zdotc( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
350 $ 1 )
351 CALL zcopy( n-k, a( k+1, k-1 ), 1, work, 1 )
352 CALL zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
353 $ 1, zero, a( k+1, k-1 ), 1 )
354 a( k-1, k-1 ) = a( k-1, k-1 ) -
355 $ dble( zdotc( n-k, work, 1, a( k+1, k-1 ),
356 $ 1 ) )
357 END IF
358 kstep = 2
359 END IF
360*
361 kp = abs( ipiv( k ) )
362 IF( kp.NE.k ) THEN
363*
364* Interchange rows and columns K and KP in the trailing
365* submatrix A(k-1:n,k-1:n)
366*
367 IF( kp.LT.n )
368 $ CALL zswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
369 DO 70 j = k + 1, kp - 1
370 temp = dconjg( a( j, k ) )
371 a( j, k ) = dconjg( a( kp, j ) )
372 a( kp, j ) = temp
373 70 CONTINUE
374 a( kp, k ) = dconjg( a( kp, k ) )
375 temp = a( k, k )
376 a( k, k ) = a( kp, kp )
377 a( kp, kp ) = temp
378 IF( kstep.EQ.2 ) THEN
379 temp = a( k, k-1 )
380 a( k, k-1 ) = a( kp, k-1 )
381 a( kp, k-1 ) = temp
382 END IF
383 END IF
384*
385 k = k - kstep
386 GO TO 60
387 80 CONTINUE
388 END IF
389*
390 RETURN
391*
392* End of ZHETRI
393*

◆ zhetri2()

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

ZHETRI2

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

Purpose:
!>
!> ZHETRI2 computes the inverse of a COMPLEX*16 hermitian indefinite matrix
!> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
!> ZHETRF. ZHETRI2 set the LEADING DIMENSION of the workspace
!> before calling ZHETRI2X 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*16 array, dimension (LDA,N)
!>          On entry, the block diagonal matrix D and the multipliers
!>          used to obtain the factor U or L as computed by ZHETRF.
!>
!>          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 ZHETRF.
!> 
[out]WORK
!>          WORK is COMPLEX*16 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 zhetri2.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*16 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 zhetri2x, zhetri, 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, 'ZHETRF', 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( 'ZHETRI2', -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 zhetri( uplo, n, a, lda, ipiv, work, info )
195 ELSE
196 CALL zhetri2x( uplo, n, a, lda, ipiv, work, nbmax, info )
197 END IF
198 RETURN
199*
200* End of ZHETRI2
201*
subroutine zhetri(uplo, n, a, lda, ipiv, work, info)
ZHETRI
Definition zhetri.f:114
subroutine zhetri2x(uplo, n, a, lda, ipiv, work, nb, info)
ZHETRI2X
Definition zhetri2x.f:120

◆ zhetri2x()

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

ZHETRI2X

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

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

◆ zhetri_3()

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

ZHETRI_3

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

Purpose:
!> ZHETRI_3 computes the inverse of a complex Hermitian indefinite
!> matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK:
!>
!>     A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**H (or L**H) is the conjugate of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is Hermitian and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> ZHETRI_3 sets the leading dimension of the workspace  before calling
!> ZHETRI_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*16 array, dimension (LDA,N)
!>          On entry, diagonal of the block diagonal matrix D and
!>          factors U or L as computed by ZHETRF_RK and ZHETRF_BK:
!>            a) ONLY diagonal elements of the Hermitian 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 Hermitian inverse of the original
!>          matrix.
!>             If UPLO = 'U': the upper triangular part of the inverse
!>             is formed and the part of A below the diagonal is not
!>             referenced;
!>             If UPLO = 'L': the lower triangular part of the inverse
!>             is formed and the part of A above the diagonal is not
!>             referenced.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in]E
!>          E is COMPLEX*16 array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian 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 ZHETRF_RK or ZHETRF_BK.
!> 
[out]WORK
!>          WORK is COMPLEX*16 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 zhetri_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*16 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 zhetri_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, 'ZHETRI_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( 'ZHETRI_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 zhetri_3x( uplo, n, a, lda, e, ipiv, work, nb, info )
238*
239 work( 1 ) = lwkopt
240*
241 RETURN
242*
243* End of ZHETRI_3
244*
subroutine zhetri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
ZHETRI_3X
Definition zhetri_3x.f:159

◆ zhetri_3x()

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

ZHETRI_3X

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

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

◆ zhetri_rook()

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

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

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

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

Definition at line 127 of file zhetri_rook.f.

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

◆ zhetrs()

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

ZHETRS

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

Purpose:
!>
!> ZHETRS solves a system of linear equations A*X = B with a complex
!> Hermitian matrix A using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by ZHETRF.
!> 
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> 
[in]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*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHETRF.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHETRF.
!> 
[in,out]B
!>          B is COMPLEX*16 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 zhetrs.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*16 A( LDA, * ), B( LDB, * )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX*16 ONE
138 parameter( one = ( 1.0d+0, 0.0d+0 ) )
139* ..
140* .. Local Scalars ..
141 LOGICAL UPPER
142 INTEGER J, K, KP
143 DOUBLE PRECISION S
144 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
145* ..
146* .. External Functions ..
147 LOGICAL LSAME
148 EXTERNAL lsame
149* ..
150* .. External Subroutines ..
151 EXTERNAL xerbla, zdscal, zgemv, zgeru, zlacgv, zswap
152* ..
153* .. Intrinsic Functions ..
154 INTRINSIC dble, dconjg, max
155* ..
156* .. Executable Statements ..
157*
158 info = 0
159 upper = lsame( uplo, 'U' )
160 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
161 info = -1
162 ELSE IF( n.LT.0 ) THEN
163 info = -2
164 ELSE IF( nrhs.LT.0 ) THEN
165 info = -3
166 ELSE IF( lda.LT.max( 1, n ) ) THEN
167 info = -5
168 ELSE IF( ldb.LT.max( 1, n ) ) THEN
169 info = -8
170 END IF
171 IF( info.NE.0 ) THEN
172 CALL xerbla( 'ZHETRS', -info )
173 RETURN
174 END IF
175*
176* Quick return if possible
177*
178 IF( n.EQ.0 .OR. nrhs.EQ.0 )
179 $ RETURN
180*
181 IF( upper ) THEN
182*
183* Solve A*X = B, where A = U*D*U**H.
184*
185* First solve U*D*X = B, overwriting B with X.
186*
187* K is the main loop index, decreasing from N to 1 in steps of
188* 1 or 2, depending on the size of the diagonal blocks.
189*
190 k = n
191 10 CONTINUE
192*
193* If K < 1, exit from loop.
194*
195 IF( k.LT.1 )
196 $ GO TO 30
197*
198 IF( ipiv( k ).GT.0 ) THEN
199*
200* 1 x 1 diagonal block
201*
202* Interchange rows K and IPIV(K).
203*
204 kp = ipiv( k )
205 IF( kp.NE.k )
206 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
207*
208* Multiply by inv(U(K)), where U(K) is the transformation
209* stored in column K of A.
210*
211 CALL zgeru( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
212 $ b( 1, 1 ), ldb )
213*
214* Multiply by the inverse of the diagonal block.
215*
216 s = dble( one ) / dble( a( k, k ) )
217 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
218 k = k - 1
219 ELSE
220*
221* 2 x 2 diagonal block
222*
223* Interchange rows K-1 and -IPIV(K).
224*
225 kp = -ipiv( k )
226 IF( kp.NE.k-1 )
227 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
228*
229* Multiply by inv(U(K)), where U(K) is the transformation
230* stored in columns K-1 and K of A.
231*
232 CALL zgeru( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
233 $ b( 1, 1 ), ldb )
234 CALL zgeru( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),
235 $ ldb, b( 1, 1 ), ldb )
236*
237* Multiply by the inverse of the diagonal block.
238*
239 akm1k = a( k-1, k )
240 akm1 = a( k-1, k-1 ) / akm1k
241 ak = a( k, k ) / dconjg( akm1k )
242 denom = akm1*ak - one
243 DO 20 j = 1, nrhs
244 bkm1 = b( k-1, j ) / akm1k
245 bk = b( k, j ) / dconjg( akm1k )
246 b( k-1, j ) = ( ak*bkm1-bk ) / denom
247 b( k, j ) = ( akm1*bk-bkm1 ) / denom
248 20 CONTINUE
249 k = k - 2
250 END IF
251*
252 GO TO 10
253 30 CONTINUE
254*
255* Next solve U**H *X = B, overwriting B with X.
256*
257* K is the main loop index, increasing from 1 to N in steps of
258* 1 or 2, depending on the size of the diagonal blocks.
259*
260 k = 1
261 40 CONTINUE
262*
263* If K > N, exit from loop.
264*
265 IF( k.GT.n )
266 $ GO TO 50
267*
268 IF( ipiv( k ).GT.0 ) THEN
269*
270* 1 x 1 diagonal block
271*
272* Multiply by inv(U**H(K)), where U(K) is the transformation
273* stored in column K of A.
274*
275 IF( k.GT.1 ) THEN
276 CALL zlacgv( nrhs, b( k, 1 ), ldb )
277 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
278 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
279 CALL zlacgv( nrhs, b( k, 1 ), ldb )
280 END IF
281*
282* Interchange rows K and IPIV(K).
283*
284 kp = ipiv( k )
285 IF( kp.NE.k )
286 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
287 k = k + 1
288 ELSE
289*
290* 2 x 2 diagonal block
291*
292* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
293* stored in columns K and K+1 of A.
294*
295 IF( k.GT.1 ) THEN
296 CALL zlacgv( nrhs, b( k, 1 ), ldb )
297 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
298 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
299 CALL zlacgv( nrhs, b( k, 1 ), ldb )
300*
301 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
302 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
303 $ ldb, a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb )
304 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
305 END IF
306*
307* Interchange rows K and -IPIV(K).
308*
309 kp = -ipiv( k )
310 IF( kp.NE.k )
311 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
312 k = k + 2
313 END IF
314*
315 GO TO 40
316 50 CONTINUE
317*
318 ELSE
319*
320* Solve A*X = B, where A = L*D*L**H.
321*
322* First solve L*D*X = B, overwriting B with X.
323*
324* K is the main loop index, increasing from 1 to N in steps of
325* 1 or 2, depending on the size of the diagonal blocks.
326*
327 k = 1
328 60 CONTINUE
329*
330* If K > N, exit from loop.
331*
332 IF( k.GT.n )
333 $ GO TO 80
334*
335 IF( ipiv( k ).GT.0 ) THEN
336*
337* 1 x 1 diagonal block
338*
339* Interchange rows K and IPIV(K).
340*
341 kp = ipiv( k )
342 IF( kp.NE.k )
343 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
344*
345* Multiply by inv(L(K)), where L(K) is the transformation
346* stored in column K of A.
347*
348 IF( k.LT.n )
349 $ CALL zgeru( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ),
350 $ ldb, b( k+1, 1 ), ldb )
351*
352* Multiply by the inverse of the diagonal block.
353*
354 s = dble( one ) / dble( a( k, k ) )
355 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
356 k = k + 1
357 ELSE
358*
359* 2 x 2 diagonal block
360*
361* Interchange rows K+1 and -IPIV(K).
362*
363 kp = -ipiv( k )
364 IF( kp.NE.k+1 )
365 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
366*
367* Multiply by inv(L(K)), where L(K) is the transformation
368* stored in columns K and K+1 of A.
369*
370 IF( k.LT.n-1 ) THEN
371 CALL zgeru( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
372 $ ldb, b( k+2, 1 ), ldb )
373 CALL zgeru( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
374 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
375 END IF
376*
377* Multiply by the inverse of the diagonal block.
378*
379 akm1k = a( k+1, k )
380 akm1 = a( k, k ) / dconjg( akm1k )
381 ak = a( k+1, k+1 ) / akm1k
382 denom = akm1*ak - one
383 DO 70 j = 1, nrhs
384 bkm1 = b( k, j ) / dconjg( akm1k )
385 bk = b( k+1, j ) / akm1k
386 b( k, j ) = ( ak*bkm1-bk ) / denom
387 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
388 70 CONTINUE
389 k = k + 2
390 END IF
391*
392 GO TO 60
393 80 CONTINUE
394*
395* Next solve L**H *X = B, overwriting B with X.
396*
397* K is the main loop index, decreasing from N to 1 in steps of
398* 1 or 2, depending on the size of the diagonal blocks.
399*
400 k = n
401 90 CONTINUE
402*
403* If K < 1, exit from loop.
404*
405 IF( k.LT.1 )
406 $ GO TO 100
407*
408 IF( ipiv( k ).GT.0 ) THEN
409*
410* 1 x 1 diagonal block
411*
412* Multiply by inv(L**H(K)), where L(K) is the transformation
413* stored in column K of A.
414*
415 IF( k.LT.n ) THEN
416 CALL zlacgv( nrhs, b( k, 1 ), ldb )
417 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
418 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
419 $ b( k, 1 ), ldb )
420 CALL zlacgv( nrhs, b( k, 1 ), ldb )
421 END IF
422*
423* Interchange rows K and IPIV(K).
424*
425 kp = ipiv( k )
426 IF( kp.NE.k )
427 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
428 k = k - 1
429 ELSE
430*
431* 2 x 2 diagonal block
432*
433* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
434* stored in columns K-1 and K of A.
435*
436 IF( k.LT.n ) THEN
437 CALL zlacgv( nrhs, b( k, 1 ), ldb )
438 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
439 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
440 $ b( k, 1 ), ldb )
441 CALL zlacgv( nrhs, b( k, 1 ), ldb )
442*
443 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
444 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
445 $ b( k+1, 1 ), ldb, a( k+1, k-1 ), 1, one,
446 $ b( k-1, 1 ), ldb )
447 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
448 END IF
449*
450* Interchange rows K and -IPIV(K).
451*
452 kp = -ipiv( k )
453 IF( kp.NE.k )
454 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
455 k = k - 2
456 END IF
457*
458 GO TO 90
459 100 CONTINUE
460 END IF
461*
462 RETURN
463*
464* End of ZHETRS
465*
subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
ZGERU
Definition zgeru.f:130

◆ zhetrs2()

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

ZHETRS2

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

Purpose:
!>
!> ZHETRS2 solves a system of linear equations A*X = B with a complex
!> Hermitian matrix A using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by ZHETRF and converted by ZSYCONV.
!> 
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> 
[in]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*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHETRF.
!> 
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> 
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHETRF.
!> 
[in,out]B
!>          B is COMPLEX*16 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*16 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 125 of file zhetrs2.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, LDB, N, NRHS
135* ..
136* .. Array Arguments ..
137 INTEGER IPIV( * )
138 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 COMPLEX*16 ONE
145 parameter( one = (1.0d+0,0.0d+0) )
146* ..
147* .. Local Scalars ..
148 LOGICAL UPPER
149 INTEGER I, IINFO, J, K, KP
150 DOUBLE PRECISION S
151 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 EXTERNAL lsame
156* ..
157* .. External Subroutines ..
158 EXTERNAL zdscal, zsyconv, zswap, ztrsm, xerbla
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC dble, dconjg, max
162* ..
163* .. Executable Statements ..
164*
165 info = 0
166 upper = lsame( uplo, 'U' )
167 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
168 info = -1
169 ELSE IF( n.LT.0 ) THEN
170 info = -2
171 ELSE IF( nrhs.LT.0 ) THEN
172 info = -3
173 ELSE IF( lda.LT.max( 1, n ) ) THEN
174 info = -5
175 ELSE IF( ldb.LT.max( 1, n ) ) THEN
176 info = -8
177 END IF
178 IF( info.NE.0 ) THEN
179 CALL xerbla( 'ZHETRS2', -info )
180 RETURN
181 END IF
182*
183* Quick return if possible
184*
185 IF( n.EQ.0 .OR. nrhs.EQ.0 )
186 $ RETURN
187*
188* Convert A
189*
190 CALL zsyconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
191*
192 IF( upper ) THEN
193*
194* Solve A*X = B, where A = U*D*U**H.
195*
196* P**T * B
197 k=n
198 DO WHILE ( k .GE. 1 )
199 IF( ipiv( k ).GT.0 ) THEN
200* 1 x 1 diagonal block
201* Interchange rows K and IPIV(K).
202 kp = ipiv( k )
203 IF( kp.NE.k )
204 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
205 k=k-1
206 ELSE
207* 2 x 2 diagonal block
208* Interchange rows K-1 and -IPIV(K).
209 kp = -ipiv( k )
210 IF( kp.EQ.-ipiv( k-1 ) )
211 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
212 k=k-2
213 END IF
214 END DO
215*
216* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
217*
218 CALL ztrsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb)
219*
220* Compute D \ B -> B [ D \ (U \P**T * B) ]
221*
222 i=n
223 DO WHILE ( i .GE. 1 )
224 IF( ipiv(i) .GT. 0 ) THEN
225 s = dble( one ) / dble( a( i, i ) )
226 CALL zdscal( nrhs, s, b( i, 1 ), ldb )
227 ELSEIF ( i .GT. 1) THEN
228 IF ( ipiv(i-1) .EQ. ipiv(i) ) THEN
229 akm1k = work(i)
230 akm1 = a( i-1, i-1 ) / akm1k
231 ak = a( i, i ) / dconjg( akm1k )
232 denom = akm1*ak - one
233 DO 15 j = 1, nrhs
234 bkm1 = b( i-1, j ) / akm1k
235 bk = b( i, j ) / dconjg( akm1k )
236 b( i-1, j ) = ( ak*bkm1-bk ) / denom
237 b( i, j ) = ( akm1*bk-bkm1 ) / denom
238 15 CONTINUE
239 i = i - 1
240 ENDIF
241 ENDIF
242 i = i - 1
243 END DO
244*
245* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ]
246*
247 CALL ztrsm('L','U','C','U',n,nrhs,one,a,lda,b,ldb)
248*
249* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ]
250*
251 k=1
252 DO WHILE ( k .LE. n )
253 IF( ipiv( k ).GT.0 ) THEN
254* 1 x 1 diagonal block
255* Interchange rows K and IPIV(K).
256 kp = ipiv( k )
257 IF( kp.NE.k )
258 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
259 k=k+1
260 ELSE
261* 2 x 2 diagonal block
262* Interchange rows K-1 and -IPIV(K).
263 kp = -ipiv( k )
264 IF( k .LT. n .AND. kp.EQ.-ipiv( k+1 ) )
265 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
266 k=k+2
267 ENDIF
268 END DO
269*
270 ELSE
271*
272* Solve A*X = B, where A = L*D*L**H.
273*
274* P**T * B
275 k=1
276 DO WHILE ( k .LE. n )
277 IF( ipiv( k ).GT.0 ) THEN
278* 1 x 1 diagonal block
279* Interchange rows K and IPIV(K).
280 kp = ipiv( k )
281 IF( kp.NE.k )
282 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
283 k=k+1
284 ELSE
285* 2 x 2 diagonal block
286* Interchange rows K and -IPIV(K+1).
287 kp = -ipiv( k+1 )
288 IF( kp.EQ.-ipiv( k ) )
289 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
290 k=k+2
291 ENDIF
292 END DO
293*
294* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
295*
296 CALL ztrsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb)
297*
298* Compute D \ B -> B [ D \ (L \P**T * B) ]
299*
300 i=1
301 DO WHILE ( i .LE. n )
302 IF( ipiv(i) .GT. 0 ) THEN
303 s = dble( one ) / dble( a( i, i ) )
304 CALL zdscal( nrhs, s, b( i, 1 ), ldb )
305 ELSE
306 akm1k = work(i)
307 akm1 = a( i, i ) / dconjg( akm1k )
308 ak = a( i+1, i+1 ) / akm1k
309 denom = akm1*ak - one
310 DO 25 j = 1, nrhs
311 bkm1 = b( i, j ) / dconjg( akm1k )
312 bk = b( i+1, j ) / akm1k
313 b( i, j ) = ( ak*bkm1-bk ) / denom
314 b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
315 25 CONTINUE
316 i = i + 1
317 ENDIF
318 i = i + 1
319 END DO
320*
321* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ]
322*
323 CALL ztrsm('L','L','C','U',n,nrhs,one,a,lda,b,ldb)
324*
325* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ]
326*
327 k=n
328 DO WHILE ( k .GE. 1 )
329 IF( ipiv( k ).GT.0 ) THEN
330* 1 x 1 diagonal block
331* Interchange rows K and IPIV(K).
332 kp = ipiv( k )
333 IF( kp.NE.k )
334 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
335 k=k-1
336 ELSE
337* 2 x 2 diagonal block
338* Interchange rows K-1 and -IPIV(K).
339 kp = -ipiv( k )
340 IF( k.GT.1 .AND. kp.EQ.-ipiv( k-1 ) )
341 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
342 k=k-2
343 ENDIF
344 END DO
345*
346 END IF
347*
348* Revert A
349*
350 CALL zsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
351*
352 RETURN
353*
354* End of ZHETRS2
355*

◆ zhetrs_3()

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

ZHETRS_3

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

Purpose:
!> ZHETRS_3 solves a system of linear equations A * X = B with a complex
!> Hermitian matrix A using the factorization computed
!> by ZHETRF_RK or ZHETRF_BK:
!>
!>    A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**H (or L**H) is the conjugate of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is Hermitian 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**H)*(P**T);
!>          = 'L':  Lower triangular, form is A = P*L*D*(L**H)*(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*16 array, dimension (LDA,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by ZHETRF_RK and ZHETRF_BK:
!>            a) ONLY diagonal elements of the Hermitian 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*16 array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian 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 ZHETRF_RK or ZHETRF_BK.
!> 
[in,out]B
!>          B is COMPLEX*16 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 zhetrs_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*16 A( LDA, * ), B( LDB, * ), E( * )
177* ..
178*
179* =====================================================================
180*
181* .. Parameters ..
182 COMPLEX*16 ONE
183 parameter( one = ( 1.0d+0,0.0d+0 ) )
184* ..
185* .. Local Scalars ..
186 LOGICAL UPPER
187 INTEGER I, J, K, KP
188 DOUBLE PRECISION S
189 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
190* ..
191* .. External Functions ..
192 LOGICAL LSAME
193 EXTERNAL lsame
194* ..
195* .. External Subroutines ..
196 EXTERNAL zdscal, zswap, ztrsm, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, dble, dconjg, max
200* ..
201* .. Executable Statements ..
202*
203 info = 0
204 upper = lsame( uplo, 'U' )
205 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
206 info = -1
207 ELSE IF( n.LT.0 ) THEN
208 info = -2
209 ELSE IF( nrhs.LT.0 ) THEN
210 info = -3
211 ELSE IF( lda.LT.max( 1, n ) ) THEN
212 info = -5
213 ELSE IF( ldb.LT.max( 1, n ) ) THEN
214 info = -9
215 END IF
216 IF( info.NE.0 ) THEN
217 CALL xerbla( 'ZHETRS_3', -info )
218 RETURN
219 END IF
220*
221* Quick return if possible
222*
223 IF( n.EQ.0 .OR. nrhs.EQ.0 )
224 $ RETURN
225*
226 IF( upper ) THEN
227*
228* Begin Upper
229*
230* Solve A*X = B, where A = U*D*U**H.
231*
232* P**T * B
233*
234* Interchange rows K and IPIV(K) of matrix B in the same order
235* that the formation order of IPIV(I) vector for Upper case.
236*
237* (We can do the simple loop over IPIV with decrement -1,
238* since the ABS value of IPIV(I) represents the row index
239* of the interchange with row i in both 1x1 and 2x2 pivot cases)
240*
241 DO k = n, 1, -1
242 kp = abs( ipiv( k ) )
243 IF( kp.NE.k ) THEN
244 CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
245 END IF
246 END DO
247*
248* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
249*
250 CALL ztrsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b, ldb )
251*
252* Compute D \ B -> B [ D \ (U \P**T * B) ]
253*
254 i = n
255 DO WHILE ( i.GE.1 )
256 IF( ipiv( i ).GT.0 ) THEN
257 s = dble( one ) / dble( a( i, i ) )
258 CALL zdscal( nrhs, s, b( i, 1 ), ldb )
259 ELSE IF ( i.GT.1 ) THEN
260 akm1k = e( i )
261 akm1 = a( i-1, i-1 ) / akm1k
262 ak = a( i, i ) / dconjg( akm1k )
263 denom = akm1*ak - one
264 DO j = 1, nrhs
265 bkm1 = b( i-1, j ) / akm1k
266 bk = b( i, j ) / dconjg( akm1k )
267 b( i-1, j ) = ( ak*bkm1-bk ) / denom
268 b( i, j ) = ( akm1*bk-bkm1 ) / denom
269 END DO
270 i = i - 1
271 END IF
272 i = i - 1
273 END DO
274*
275* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ]
276*
277 CALL ztrsm( 'L', 'U', 'C', 'U', n, nrhs, one, a, lda, b, ldb )
278*
279* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ]
280*
281* Interchange rows K and IPIV(K) of matrix B in reverse order
282* from the formation order of IPIV(I) vector for Upper case.
283*
284* (We can do the simple loop over IPIV with increment 1,
285* since the ABS value of IPIV(I) represents the row index
286* of the interchange with row i in both 1x1 and 2x2 pivot cases)
287*
288 DO k = 1, n, 1
289 kp = abs( ipiv( k ) )
290 IF( kp.NE.k ) THEN
291 CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
292 END IF
293 END DO
294*
295 ELSE
296*
297* Begin Lower
298*
299* Solve A*X = B, where A = L*D*L**H.
300*
301* P**T * B
302* Interchange rows K and IPIV(K) of matrix B in the same order
303* that the formation order of IPIV(I) vector for Lower case.
304*
305* (We can do the simple loop over IPIV with increment 1,
306* since the ABS value of IPIV(I) represents the row index
307* of the interchange with row i in both 1x1 and 2x2 pivot cases)
308*
309 DO k = 1, n, 1
310 kp = abs( ipiv( k ) )
311 IF( kp.NE.k ) THEN
312 CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
313 END IF
314 END DO
315*
316* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
317*
318 CALL ztrsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb )
319*
320* Compute D \ B -> B [ D \ (L \P**T * B) ]
321*
322 i = 1
323 DO WHILE ( i.LE.n )
324 IF( ipiv( i ).GT.0 ) THEN
325 s = dble( one ) / dble( a( i, i ) )
326 CALL zdscal( nrhs, s, b( i, 1 ), ldb )
327 ELSE IF( i.LT.n ) THEN
328 akm1k = e( i )
329 akm1 = a( i, i ) / dconjg( akm1k )
330 ak = a( i+1, i+1 ) / akm1k
331 denom = akm1*ak - one
332 DO j = 1, nrhs
333 bkm1 = b( i, j ) / dconjg( akm1k )
334 bk = b( i+1, j ) / akm1k
335 b( i, j ) = ( ak*bkm1-bk ) / denom
336 b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
337 END DO
338 i = i + 1
339 END IF
340 i = i + 1
341 END DO
342*
343* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ]
344*
345 CALL ztrsm('L', 'L', 'C', 'U', n, nrhs, one, a, lda, b, ldb )
346*
347* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ]
348*
349* Interchange rows K and IPIV(K) of matrix B in reverse order
350* from the formation order of IPIV(I) vector for Lower case.
351*
352* (We can do the simple loop over IPIV with decrement -1,
353* since the ABS value of IPIV(I) represents the row index
354* of the interchange with row i in both 1x1 and 2x2 pivot cases)
355*
356 DO k = n, 1, -1
357 kp = abs( ipiv( k ) )
358 IF( kp.NE.k ) THEN
359 CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
360 END IF
361 END DO
362*
363* END Lower
364*
365 END IF
366*
367 RETURN
368*
369* End of ZHETRS_3
370*

◆ zhetrs_aa()

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

ZHETRS_AA

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

Purpose:
!>
!> ZHETRS_AA solves a system of linear equations A*X = B with a complex
!> hermitian matrix A using the factorization A = U**H*T*U or
!> A = L*T*L**H computed by ZHETRF_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**H*T*U;
!>          = 'L':  Lower triangular, form is A = L*T*L**H.
!> 
[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*16 array, dimension (LDA,N)
!>          Details of factors computed by ZHETRF_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 ZHETRF_AA.
!> 
[in,out]B
!>          B is COMPLEX*16 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*16 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 130 of file zhetrs_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, NRHS, LDA, LDB, LWORK, INFO
142* ..
143* .. Array Arguments ..
144 INTEGER IPIV( * )
145 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
146* ..
147*
148* =====================================================================
149*
150 COMPLEX*16 ONE
151 parameter( one = 1.0d+0 )
152* ..
153* .. Local Scalars ..
154 LOGICAL LQUERY, UPPER
155 INTEGER K, KP, LWKOPT
156* ..
157* .. External Functions ..
158 LOGICAL LSAME
159 EXTERNAL lsame
160* ..
161* .. External Subroutines ..
162 EXTERNAL zgtsv, zswap, ztrsm, zlacgv, zlacpy, xerbla
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC max
166* ..
167* .. Executable Statements ..
168*
169 info = 0
170 upper = lsame( uplo, 'U' )
171 lquery = ( lwork.EQ.-1 )
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( nrhs.LT.0 ) THEN
177 info = -3
178 ELSE IF( lda.LT.max( 1, n ) ) THEN
179 info = -5
180 ELSE IF( ldb.LT.max( 1, n ) ) THEN
181 info = -8
182 ELSE IF( lwork.LT.max( 1, 3*n-2 ) .AND. .NOT.lquery ) THEN
183 info = -10
184 END IF
185 IF( info.NE.0 ) THEN
186 CALL xerbla( 'ZHETRS_AA', -info )
187 RETURN
188 ELSE IF( lquery ) THEN
189 lwkopt = (3*n-2)
190 work( 1 ) = lwkopt
191 RETURN
192 END IF
193*
194* Quick return if possible
195*
196 IF( n.EQ.0 .OR. nrhs.EQ.0 )
197 $ RETURN
198*
199 IF( upper ) THEN
200*
201* Solve A*X = B, where A = U**H*T*U.
202*
203* 1) Forward substitution with U**H
204*
205 IF( n.GT.1 ) THEN
206*
207* Pivot, P**T * B -> B
208*
209 DO k = 1, n
210 kp = ipiv( k )
211 IF( kp.NE.k )
212 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
213 END DO
214*
215* Compute U**H \ B -> B [ (U**H \P**T * B) ]
216*
217 CALL ztrsm( 'L', 'U', 'C', 'U', n-1, nrhs, one, a( 1, 2 ),
218 $ lda, b( 2, 1 ), ldb )
219 END IF
220*
221* 2) Solve with triangular matrix T
222*
223* Compute T \ B -> B [ T \ (U**H \P**T * B) ]
224*
225 CALL zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1 )
226 IF( n.GT.1 ) THEN
227 CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1)
228 CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 )
229 CALL zlacgv( n-1, work( 1 ), 1 )
230 END IF
231 CALL zgtsv( n, nrhs, work(1), work(n), work(2*n), b, ldb,
232 $ info )
233*
234* 3) Backward substitution with U
235*
236 IF( n.GT.1 ) THEN
237*
238* Compute U \ B -> B [ U \ (T \ (U**H \P**T * B) ) ]
239*
240 CALL ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),
241 $ lda, b(2, 1), ldb)
242*
243* Pivot, P * B [ P * (U**H \ (T \ (U \P**T * B) )) ]
244*
245 DO k = n, 1, -1
246 kp = ipiv( k )
247 IF( kp.NE.k )
248 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
249 END DO
250 END IF
251*
252 ELSE
253*
254* Solve A*X = B, where A = L*T*L**H.
255*
256* 1) Forward substitution with L
257*
258 IF( n.GT.1 ) THEN
259*
260* Pivot, P**T * B -> B
261*
262 DO k = 1, n
263 kp = ipiv( k )
264 IF( kp.NE.k )
265 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
266 END DO
267*
268* Compute L \ B -> B [ (L \P**T * B) ]
269*
270 CALL ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),
271 $ lda, b(2, 1), ldb)
272 END IF
273*
274* 2) Solve with triangular matrix T
275*
276* Compute T \ B -> B [ T \ (L \P**T * B) ]
277*
278 CALL zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
279 IF( n.GT.1 ) THEN
280 CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1)
281 CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1)
282 CALL zlacgv( n-1, work( 2*n ), 1 )
283 END IF
284 CALL zgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,
285 $ info)
286*
287* 3) Backward substitution with L**H
288*
289 IF( n.GT.1 ) THEN
290*
291* Compute L**H \ B -> B [ L**H \ (T \ (L \P**T * B) ) ]
292*
293 CALL ztrsm( 'L', 'L', 'C', 'U', n-1, nrhs, one, a( 2, 1 ),
294 $ lda, b( 2, 1 ), ldb)
295*
296* Pivot, P * B [ P * (L**H \ (T \ (L \P**T * B) )) ]
297*
298 DO k = n, 1, -1
299 kp = ipiv( k )
300 IF( kp.NE.k )
301 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
302 END DO
303 END IF
304*
305 END IF
306*
307 RETURN
308*
309* End of ZHETRS_AA
310*
subroutine zgtsv(n, nrhs, dl, d, du, b, ldb, info)
ZGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition zgtsv.f:124
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103

◆ zhetrs_rook()

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

ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges)

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

Purpose:
!>
!> ZHETRS_ROOK solves a system of linear equations A*X = B with a complex
!> Hermitian matrix A using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by ZHETRF_ROOK.
!> 
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!> 
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> 
[in]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*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHETRF_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 ZHETRF_ROOK.
!> 
[in,out]B
!>          B is COMPLEX*16 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:
!>
!>  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 134 of file zhetrs_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*16 A( LDA, * ), B( LDB, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 COMPLEX*16 ONE
154 parameter( one = ( 1.0d+0, 0.0d+0 ) )
155* ..
156* .. Local Scalars ..
157 LOGICAL UPPER
158 INTEGER J, K, KP
159 DOUBLE PRECISION S
160 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 EXTERNAL lsame
165* ..
166* .. External Subroutines ..
167 EXTERNAL zgemv, zgeru, zlacgv, zdscal, zswap, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC dconjg, max, dble
171* ..
172* .. Executable Statements ..
173*
174 info = 0
175 upper = lsame( uplo, 'U' )
176 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
177 info = -1
178 ELSE IF( n.LT.0 ) THEN
179 info = -2
180 ELSE IF( nrhs.LT.0 ) THEN
181 info = -3
182 ELSE IF( lda.LT.max( 1, n ) ) THEN
183 info = -5
184 ELSE IF( ldb.LT.max( 1, n ) ) THEN
185 info = -8
186 END IF
187 IF( info.NE.0 ) THEN
188 CALL xerbla( 'ZHETRS_ROOK', -info )
189 RETURN
190 END IF
191*
192* Quick return if possible
193*
194 IF( n.EQ.0 .OR. nrhs.EQ.0 )
195 $ RETURN
196*
197 IF( upper ) THEN
198*
199* Solve A*X = B, where A = U*D*U**H.
200*
201* First solve U*D*X = B, overwriting B with X.
202*
203* K is the main loop index, decreasing from N to 1 in steps of
204* 1 or 2, depending on the size of the diagonal blocks.
205*
206 k = n
207 10 CONTINUE
208*
209* If K < 1, exit from loop.
210*
211 IF( k.LT.1 )
212 $ GO TO 30
213*
214 IF( ipiv( k ).GT.0 ) THEN
215*
216* 1 x 1 diagonal block
217*
218* Interchange rows K and IPIV(K).
219*
220 kp = ipiv( k )
221 IF( kp.NE.k )
222 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
223*
224* Multiply by inv(U(K)), where U(K) is the transformation
225* stored in column K of A.
226*
227 CALL zgeru( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
228 $ b( 1, 1 ), ldb )
229*
230* Multiply by the inverse of the diagonal block.
231*
232 s = dble( one ) / dble( a( k, k ) )
233 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
234 k = k - 1
235 ELSE
236*
237* 2 x 2 diagonal block
238*
239* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
240*
241 kp = -ipiv( k )
242 IF( kp.NE.k )
243 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
244*
245 kp = -ipiv( k-1)
246 IF( kp.NE.k-1 )
247 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
248*
249* Multiply by inv(U(K)), where U(K) is the transformation
250* stored in columns K-1 and K of A.
251*
252 CALL zgeru( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
253 $ b( 1, 1 ), ldb )
254 CALL zgeru( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),
255 $ ldb, b( 1, 1 ), ldb )
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 ) / dconjg( akm1k )
262 denom = akm1*ak - one
263 DO 20 j = 1, nrhs
264 bkm1 = b( k-1, j ) / akm1k
265 bk = b( k, j ) / dconjg( 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**H *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**H(K)), where U(K) is the transformation
293* stored in column K of A.
294*
295 IF( k.GT.1 ) THEN
296 CALL zlacgv( nrhs, b( k, 1 ), ldb )
297 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
298 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
299 CALL zlacgv( nrhs, b( k, 1 ), ldb )
300 END IF
301*
302* Interchange rows K and IPIV(K).
303*
304 kp = ipiv( k )
305 IF( kp.NE.k )
306 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
307 k = k + 1
308 ELSE
309*
310* 2 x 2 diagonal block
311*
312* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
313* stored in columns K and K+1 of A.
314*
315 IF( k.GT.1 ) THEN
316 CALL zlacgv( nrhs, b( k, 1 ), ldb )
317 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
318 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
319 CALL zlacgv( nrhs, b( k, 1 ), ldb )
320*
321 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
322 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
323 $ ldb, a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb )
324 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
325 END IF
326*
327* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
328*
329 kp = -ipiv( k )
330 IF( kp.NE.k )
331 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
332*
333 kp = -ipiv( k+1 )
334 IF( kp.NE.k+1 )
335 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
336*
337 k = k + 2
338 END IF
339*
340 GO TO 40
341 50 CONTINUE
342*
343 ELSE
344*
345* Solve A*X = B, where A = L*D*L**H.
346*
347* First solve L*D*X = B, overwriting B with X.
348*
349* K is the main loop index, increasing from 1 to N in steps of
350* 1 or 2, depending on the size of the diagonal blocks.
351*
352 k = 1
353 60 CONTINUE
354*
355* If K > N, exit from loop.
356*
357 IF( k.GT.n )
358 $ GO TO 80
359*
360 IF( ipiv( k ).GT.0 ) THEN
361*
362* 1 x 1 diagonal block
363*
364* Interchange rows K and IPIV(K).
365*
366 kp = ipiv( k )
367 IF( kp.NE.k )
368 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
369*
370* Multiply by inv(L(K)), where L(K) is the transformation
371* stored in column K of A.
372*
373 IF( k.LT.n )
374 $ CALL zgeru( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ),
375 $ ldb, b( k+1, 1 ), ldb )
376*
377* Multiply by the inverse of the diagonal block.
378*
379 s = dble( one ) / dble( a( k, k ) )
380 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
381 k = k + 1
382 ELSE
383*
384* 2 x 2 diagonal block
385*
386* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1)
387*
388 kp = -ipiv( k )
389 IF( kp.NE.k )
390 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
391*
392 kp = -ipiv( k+1 )
393 IF( kp.NE.k+1 )
394 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
395*
396* Multiply by inv(L(K)), where L(K) is the transformation
397* stored in columns K and K+1 of A.
398*
399 IF( k.LT.n-1 ) THEN
400 CALL zgeru( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
401 $ ldb, b( k+2, 1 ), ldb )
402 CALL zgeru( n-k-1, nrhs, -one, a( k+2, k+1 ), 1,
403 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
404 END IF
405*
406* Multiply by the inverse of the diagonal block.
407*
408 akm1k = a( k+1, k )
409 akm1 = a( k, k ) / dconjg( akm1k )
410 ak = a( k+1, k+1 ) / akm1k
411 denom = akm1*ak - one
412 DO 70 j = 1, nrhs
413 bkm1 = b( k, j ) / dconjg( akm1k )
414 bk = b( k+1, j ) / akm1k
415 b( k, j ) = ( ak*bkm1-bk ) / denom
416 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
417 70 CONTINUE
418 k = k + 2
419 END IF
420*
421 GO TO 60
422 80 CONTINUE
423*
424* Next solve L**H *X = B, overwriting B with X.
425*
426* K is the main loop index, decreasing from N to 1 in steps of
427* 1 or 2, depending on the size of the diagonal blocks.
428*
429 k = n
430 90 CONTINUE
431*
432* If K < 1, exit from loop.
433*
434 IF( k.LT.1 )
435 $ GO TO 100
436*
437 IF( ipiv( k ).GT.0 ) THEN
438*
439* 1 x 1 diagonal block
440*
441* Multiply by inv(L**H(K)), where L(K) is the transformation
442* stored in column K of A.
443*
444 IF( k.LT.n ) THEN
445 CALL zlacgv( nrhs, b( k, 1 ), ldb )
446 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
447 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
448 $ b( k, 1 ), ldb )
449 CALL zlacgv( nrhs, b( k, 1 ), ldb )
450 END IF
451*
452* Interchange rows K and IPIV(K).
453*
454 kp = ipiv( k )
455 IF( kp.NE.k )
456 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
457 k = k - 1
458 ELSE
459*
460* 2 x 2 diagonal block
461*
462* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
463* stored in columns K-1 and K of A.
464*
465 IF( k.LT.n ) THEN
466 CALL zlacgv( nrhs, b( k, 1 ), ldb )
467 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
468 $ b( k+1, 1 ), ldb, a( k+1, k ), 1, one,
469 $ b( k, 1 ), ldb )
470 CALL zlacgv( nrhs, b( k, 1 ), ldb )
471*
472 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
473 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
474 $ b( k+1, 1 ), ldb, a( k+1, k-1 ), 1, one,
475 $ b( k-1, 1 ), ldb )
476 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
477 END IF
478*
479* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1)
480*
481 kp = -ipiv( k )
482 IF( kp.NE.k )
483 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
484*
485 kp = -ipiv( k-1 )
486 IF( kp.NE.k-1 )
487 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
488*
489 k = k - 2
490 END IF
491*
492 GO TO 90
493 100 CONTINUE
494 END IF
495*
496 RETURN
497*
498* End of ZHETRS_ROOK
499*

◆ zla_heamv()

subroutine zla_heamv ( integer uplo,
integer n,
double precision alpha,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) x,
integer incx,
double precision beta,
double precision, dimension( * ) y,
integer incy )

ZLA_HEAMV computes a matrix-vector product using a Hermitian indefinite matrix to calculate error bounds.

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

Purpose:
!>
!> ZLA_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 DOUBLE PRECISION .
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!> 
[in]A
!>          A is COMPLEX*16 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*16 array, dimension at least
!>           ( 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 DOUBLE PRECISION .
!>           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 DOUBLE PRECISION 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 176 of file zla_heamv.f.

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

◆ zla_hercond_c()

double precision function zla_hercond_c ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
double precision, dimension ( * ) c,
logical capply,
integer info,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork )

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

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

Purpose:
!>
!>    ZLA_HERCOND_C computes the infinity norm condition number of
!>    op(A) * inv(diag(C)) where C is a DOUBLE PRECISION 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*16 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*16 array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by ZHETRF.
!> 
[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 CHETRF.
!> 
[in]C
!>          C is DOUBLE PRECISION 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*16 array, dimension (2*N).
!>     Workspace.
!> 
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N).
!>     Workspace.
!> 
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file zla_hercond_c.f.

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

◆ zla_hercond_x()

double precision function zla_hercond_x ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
complex*16, dimension( * ) x,
integer info,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork )

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

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

Purpose:
!>
!>    ZLA_HERCOND_X computes the infinity norm condition number of
!>    op(A) * diag(X) where X is a COMPLEX*16 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*16 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*16 array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by ZHETRF.
!> 
[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 CHETRF.
!> 
[in]X
!>          X is COMPLEX*16 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*16 array, dimension (2*N).
!>     Workspace.
!> 
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N).
!>     Workspace.
!> 
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 130 of file zla_hercond_x.f.

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

◆ zla_herfsx_extended()

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

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

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

Purpose:
!>
!> ZLA_HERFSX_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 ZHERFSX 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*16 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*16 array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by ZHETRF.
!> 
[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 ZHETRF.
!> 
[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 DOUBLE PRECISION 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*16 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*16 array, dimension (LDY,NRHS)
!>     On entry, the solution matrix X, as computed by ZHETRS.
!>     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 DOUBLE PRECISION 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 ZLA_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 DOUBLE PRECISION 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 DOUBLE PRECISION 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*16 array, dimension (N)
!>     Workspace to hold the intermediate residual.
!> 
[in]AYB
!>          AYB is DOUBLE PRECISION array, dimension (N)
!>     Workspace.
!> 
[in]DY
!>          DY is COMPLEX*16 array, dimension (N)
!>     Workspace to hold the intermediate solution.
!> 
[in]Y_TAIL
!>          Y_TAIL is COMPLEX*16 array, dimension (N)
!>     Workspace to hold the trailing bits of the intermediate solution.
!> 
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>     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 DOUBLE PRECISION
!>     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 DOUBLE PRECISION
!>     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 ZLA_HERFSX_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 zla_herfsx_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 DOUBLE PRECISION RTHRESH, DZ_UB
406* ..
407* .. Array Arguments ..
408 INTEGER IPIV( * )
409 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
410 $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * )
411 DOUBLE PRECISION 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 DOUBLE PRECISION 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*16 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 zaxpy, zcopy, zhetrs, zhemv, blas_zhemv_x,
461 $ blas_zhemv2_x, zla_heamv, zla_wwaddw,
463 DOUBLE PRECISION DLAMCH
464* ..
465* .. Intrinsic Functions ..
466 INTRINSIC abs, dble, dimag, max, min
467* ..
468* .. Statement Functions ..
469 DOUBLE PRECISION CABS1
470* ..
471* .. Statement Function Definitions ..
472 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZLA_HERFSX_EXTENDED', -info )
495 RETURN
496 END IF
497 eps = dlamch( 'Epsilon' )
498 hugeval = dlamch( 'Overflow' )
499* Force HUGEVAL to Inf
500 hugeval = hugeval * hugeval
501* Using HUGEVAL may lead to spurious underflows.
502 incr_thresh = dble( 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.0d+0
515 END DO
516 END IF
517
518 dxrat = 0.0d+0
519 dxratmax = 0.0d+0
520 dzrat = 0.0d+0
521 dzratmax = 0.0d+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 zcopy( n, b( 1, j ), 1, res, 1 )
539 IF ( y_prec_state .EQ. base_residual ) THEN
540 CALL zhemv( uplo, n, dcmplx(-1.0d+0), a, lda, y( 1, j ),
541 $ 1, dcmplx(1.0d+0), res, 1 )
542 ELSE IF ( y_prec_state .EQ. extra_residual ) THEN
543 CALL blas_zhemv_x( uplo2, n, dcmplx(-1.0d+0), a, lda,
544 $ y( 1, j ), 1, dcmplx(1.0d+0), res, 1, prec_type)
545 ELSE
546 CALL blas_zhemv2_x(uplo2, n, dcmplx(-1.0d+0), a, lda,
547 $ y(1, j), y_tail, 1, dcmplx(1.0d+0), res, 1,
548 $ prec_type)
549 END IF
550
551! XXX: RES is no longer needed.
552 CALL zcopy( n, res, 1, dy, 1 )
553 CALL zhetrs( uplo, n, 1, af, ldaf, ipiv, dy, n, info )
554*
555* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT.
556*
557 normx = 0.0d+0
558 normy = 0.0d+0
559 normdx = 0.0d+0
560 dz_z = 0.0d+0
561 ymin = hugeval
562
563 DO i = 1, n
564 yk = cabs1( y( i, j ) )
565 dyk = cabs1( dy( i ) )
566
567 IF (yk .NE. 0.0d+0) THEN
568 dz_z = max( dz_z, dyk / yk )
569 ELSE IF ( dyk .NE. 0.0d+0 ) THEN
570 dz_z = hugeval
571 END IF
572
573 ymin = min( ymin, yk )
574
575 normy = max( normy, yk )
576
577 IF ( colequ ) THEN
578 normx = max( normx, yk * c( i ) )
579 normdx = max( normdx, dyk * c( i ) )
580 ELSE
581 normx = normy
582 normdx = max( normdx, dyk )
583 END IF
584 END DO
585
586 IF ( normx .NE. 0.0d+0 ) THEN
587 dx_x = normdx / normx
588 ELSE IF ( normdx .EQ. 0.0d+0 ) THEN
589 dx_x = 0.0d+0
590 ELSE
591 dx_x = hugeval
592 END IF
593
594 dxrat = normdx / prevnormdx
595 dzrat = dz_z / prev_dz_z
596*
597* Check termination criteria.
598*
599 IF ( ymin*rcond .LT. incr_thresh*normy
600 $ .AND. y_prec_state .LT. extra_y )
601 $ incr_prec = .true.
602
603 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
604 $ x_state = working_state
605 IF ( x_state .EQ. working_state ) THEN
606 IF ( dx_x .LE. eps ) THEN
607 x_state = conv_state
608 ELSE IF ( dxrat .GT. rthresh ) THEN
609 IF ( y_prec_state .NE. extra_y ) THEN
610 incr_prec = .true.
611 ELSE
612 x_state = noprog_state
613 END IF
614 ELSE
615 IF (dxrat .GT. dxratmax) dxratmax = dxrat
616 END IF
617 IF ( x_state .GT. working_state ) final_dx_x = dx_x
618 END IF
619
620 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
621 $ z_state = working_state
622 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
623 $ z_state = working_state
624 IF ( z_state .EQ. working_state ) THEN
625 IF ( dz_z .LE. eps ) THEN
626 z_state = conv_state
627 ELSE IF ( dz_z .GT. dz_ub ) THEN
628 z_state = unstable_state
629 dzratmax = 0.0d+0
630 final_dz_z = hugeval
631 ELSE IF ( dzrat .GT. rthresh ) THEN
632 IF ( y_prec_state .NE. extra_y ) THEN
633 incr_prec = .true.
634 ELSE
635 z_state = noprog_state
636 END IF
637 ELSE
638 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
639 END IF
640 IF ( z_state .GT. working_state ) final_dz_z = dz_z
641 END IF
642
643 IF ( x_state.NE.working_state.AND.
644 $ ( ignore_cwise.OR.z_state.NE.working_state ) )
645 $ GOTO 666
646
647 IF ( incr_prec ) THEN
648 incr_prec = .false.
649 y_prec_state = y_prec_state + 1
650 DO i = 1, n
651 y_tail( i ) = 0.0d+0
652 END DO
653 END IF
654
655 prevnormdx = normdx
656 prev_dz_z = dz_z
657*
658* Update soluton.
659*
660 IF ( y_prec_state .LT. extra_y ) THEN
661 CALL zaxpy( n, dcmplx(1.0d+0), dy, 1, y(1,j), 1 )
662 ELSE
663 CALL zla_wwaddw( n, y(1,j), y_tail, dy )
664 END IF
665
666 END DO
667* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT.
668 666 CONTINUE
669*
670* Set final_* when cnt hits ithresh.
671*
672 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
673 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
674*
675* Compute error bounds.
676*
677 IF ( n_norms .GE. 1 ) THEN
678 err_bnds_norm( j, la_linrx_err_i ) =
679 $ final_dx_x / (1 - dxratmax)
680 END IF
681 IF (n_norms .GE. 2) THEN
682 err_bnds_comp( j, la_linrx_err_i ) =
683 $ final_dz_z / (1 - dzratmax)
684 END IF
685*
686* Compute componentwise relative backward error from formula
687* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
688* where abs(Z) is the componentwise absolute value of the matrix
689* or vector Z.
690*
691* Compute residual RES = B_s - op(A_s) * Y,
692* op(A) = A, A**T, or A**H depending on TRANS (and type).
693*
694 CALL zcopy( n, b( 1, j ), 1, res, 1 )
695 CALL zhemv( uplo, n, dcmplx(-1.0d+0), a, lda, y(1,j), 1,
696 $ dcmplx(1.0d+0), res, 1 )
697
698 DO i = 1, n
699 ayb( i ) = cabs1( b( i, j ) )
700 END DO
701*
702* Compute abs(op(A_s))*abs(Y) + abs(B_s).
703*
704 CALL zla_heamv( uplo2, n, 1.0d+0,
705 $ a, lda, y(1, j), 1, 1.0d+0, ayb, 1 )
706
707 CALL zla_lin_berr( n, n, 1, res, ayb, berr_out( j ) )
708*
709* End of loop for each RHS.
710*
711 END DO
712*
713 RETURN
714*
715* End of ZLA_HERFSX_EXTENDED
716*
subroutine zla_heamv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
ZLA_HEAMV computes a matrix-vector product using a Hermitian indefinite matrix to calculate error bou...
Definition zla_heamv.f:178
subroutine zla_lin_berr(n, nz, nrhs, res, ayb, berr)
ZLA_LIN_BERR computes a component-wise relative backward error.
subroutine zla_wwaddw(n, x, y, w)
ZLA_WWADDW adds a vector into a doubled-single vector.
Definition zla_wwaddw.f:81

◆ zla_herpvgrw()

double precision function zla_herpvgrw ( character*1 uplo,
integer n,
integer info,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work )

ZLA_HERPVGRW

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

Purpose:
!>
!>
!> ZLA_HERPVGRW 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 ZHETRF, .i.e., the pivot in
!>     column INFO is exactly 0.
!> 
[in]A
!>          A is COMPLEX*16 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*16 array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by ZHETRF.
!> 
[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 ZHETRF.
!> 
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (2*N)
!> 
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ zlahef()

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

ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).

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

Purpose:
!>
!> ZLAHEF computes a partial factorization of a complex Hermitian
!> 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**H U22**H )
!>
!> A  =  ( L11  0 ) (  D   0  ) ( L11**H L21**H )  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**H denotes the conjugate transpose of U.
!>
!> ZLAHEF is an auxiliary routine called by ZHETRF. 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
!>          Hermitian 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*16 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, 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*16 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:
!>
!>  December 2016,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!> 

Definition at line 176 of file zlahef.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*16 A( LDA, * ), W( LDW, * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO, ONE
195 parameter( zero = 0.0d+0, one = 1.0d+0 )
196 COMPLEX*16 CONE
197 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
198 DOUBLE PRECISION EIGHT, SEVTEN
199 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
200* ..
201* .. Local Scalars ..
202 INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
203 $ KSTEP, KW
204 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T
205 COMPLEX*16 D11, D21, D22, Z
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 INTEGER IZAMAX
210 EXTERNAL lsame, izamax
211* ..
212* .. External Subroutines ..
213 EXTERNAL zcopy, zdscal, zgemm, zgemv, zlacgv, zswap
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC abs, dble, dconjg, dimag, max, min, sqrt
217* ..
218* .. Statement Functions ..
219 DOUBLE PRECISION CABS1
220* ..
221* .. Statement Function definitions ..
222 cabs1( z ) = abs( dble( z ) ) + abs( dimag( 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 (note that conjg(W) is actually stored)
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 kstep = 1
252*
253* Copy column K of A to column KW of W and update it
254*
255 CALL zcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 )
256 w( k, kw ) = dble( a( k, k ) )
257 IF( k.LT.n ) THEN
258 CALL zgemv( 'No transpose', k, n-k, -cone, a( 1, k+1 ), lda,
259 $ w( k, kw+1 ), ldw, cone, w( 1, kw ), 1 )
260 w( k, kw ) = dble( w( k, kw ) )
261 END IF
262*
263* Determine rows and columns to be interchanged and whether
264* a 1-by-1 or 2-by-2 pivot block will be used
265*
266 absakk = abs( dble( w( k, kw ) ) )
267*
268* IMAX is the row-index of the largest off-diagonal element in
269* column K, and COLMAX is its absolute value.
270* Determine both COLMAX and IMAX.
271*
272 IF( k.GT.1 ) THEN
273 imax = izamax( k-1, w( 1, kw ), 1 )
274 colmax = cabs1( w( imax, kw ) )
275 ELSE
276 colmax = zero
277 END IF
278*
279 IF( max( absakk, colmax ).EQ.zero ) THEN
280*
281* Column K is zero or underflow: set INFO and continue
282*
283 IF( info.EQ.0 )
284 $ info = k
285 kp = k
286 a( k, k ) = dble( a( k, k ) )
287 ELSE
288*
289* ============================================================
290*
291* BEGIN pivot search
292*
293* Case(1)
294 IF( absakk.GE.alpha*colmax ) THEN
295*
296* no interchange, use 1-by-1 pivot block
297*
298 kp = k
299 ELSE
300*
301* BEGIN pivot search along IMAX row
302*
303*
304* Copy column IMAX to column KW-1 of W and update it
305*
306 CALL zcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ), 1 )
307 w( imax, kw-1 ) = dble( a( imax, imax ) )
308 CALL zcopy( k-imax, a( imax, imax+1 ), lda,
309 $ w( imax+1, kw-1 ), 1 )
310 CALL zlacgv( k-imax, w( imax+1, kw-1 ), 1 )
311 IF( k.LT.n ) THEN
312 CALL zgemv( 'No transpose', k, n-k, -cone,
313 $ a( 1, k+1 ), lda, w( imax, kw+1 ), ldw,
314 $ cone, w( 1, kw-1 ), 1 )
315 w( imax, kw-1 ) = dble( w( imax, kw-1 ) )
316 END IF
317*
318* JMAX is the column-index of the largest off-diagonal
319* element in row IMAX, and ROWMAX is its absolute value.
320* Determine only ROWMAX.
321*
322 jmax = imax + izamax( k-imax, w( imax+1, kw-1 ), 1 )
323 rowmax = cabs1( w( jmax, kw-1 ) )
324 IF( imax.GT.1 ) THEN
325 jmax = izamax( imax-1, w( 1, kw-1 ), 1 )
326 rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) )
327 END IF
328*
329* Case(2)
330 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
331*
332* no interchange, use 1-by-1 pivot block
333*
334 kp = k
335*
336* Case(3)
337 ELSE IF( abs( dble( w( imax, kw-1 ) ) ).GE.alpha*rowmax )
338 $ THEN
339*
340* interchange rows and columns K and IMAX, use 1-by-1
341* pivot block
342*
343 kp = imax
344*
345* copy column KW-1 of W to column KW of W
346*
347 CALL zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
348*
349* Case(4)
350 ELSE
351*
352* interchange rows and columns K-1 and IMAX, use 2-by-2
353* pivot block
354*
355 kp = imax
356 kstep = 2
357 END IF
358*
359*
360* END pivot search along IMAX row
361*
362 END IF
363*
364* END pivot search
365*
366* ============================================================
367*
368* KK is the column of A where pivoting step stopped
369*
370 kk = k - kstep + 1
371*
372* KKW is the column of W which corresponds to column KK of A
373*
374 kkw = nb + kk - n
375*
376* Interchange rows and columns KP and KK.
377* Updated column KP is already stored in column KKW of W.
378*
379 IF( kp.NE.kk ) THEN
380*
381* Copy non-updated column KK to column KP of submatrix A
382* at step K. No need to copy element into column K
383* (or K and K-1 for 2-by-2 pivot) of A, since these columns
384* will be later overwritten.
385*
386 a( kp, kp ) = dble( a( kk, kk ) )
387 CALL zcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
388 $ lda )
389 CALL zlacgv( kk-1-kp, a( kp, kp+1 ), lda )
390 IF( kp.GT.1 )
391 $ CALL zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
392*
393* Interchange rows KK and KP in last K+1 to N columns of A
394* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
395* later overwritten). Interchange rows KK and KP
396* in last KKW to NB columns of W.
397*
398 IF( k.LT.n )
399 $ CALL zswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
400 $ lda )
401 CALL zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),
402 $ ldw )
403 END IF
404*
405 IF( kstep.EQ.1 ) THEN
406*
407* 1-by-1 pivot block D(k): column kw of W now holds
408*
409* W(kw) = U(k)*D(k),
410*
411* where U(k) is the k-th column of U
412*
413* (1) Store subdiag. elements of column U(k)
414* and 1-by-1 block D(k) in column k of A.
415* (NOTE: Diagonal element U(k,k) is a UNIT element
416* and not stored)
417* A(k,k) := D(k,k) = W(k,kw)
418* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
419*
420* (NOTE: No need to use for Hermitian matrix
421* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
422* element D(k,k) from W (potentially saves only one load))
423 CALL zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
424 IF( k.GT.1 ) THEN
425*
426* (NOTE: No need to check if A(k,k) is NOT ZERO,
427* since that was ensured earlier in pivot search:
428* case A(k,k) = 0 falls into 2x2 pivot case(4))
429*
430 r1 = one / dble( a( k, k ) )
431 CALL zdscal( k-1, r1, a( 1, k ), 1 )
432*
433* (2) Conjugate column W(kw)
434*
435 CALL zlacgv( k-1, w( 1, kw ), 1 )
436 END IF
437*
438 ELSE
439*
440* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
441*
442* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
443*
444* where U(k) and U(k-1) are the k-th and (k-1)-th columns
445* of U
446*
447* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
448* block D(k-1:k,k-1:k) in columns k-1 and k of A.
449* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
450* block and not stored)
451* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
452* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
453* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
454*
455 IF( k.GT.2 ) THEN
456*
457* Factor out the columns of the inverse of 2-by-2 pivot
458* block D, so that each column contains 1, to reduce the
459* number of FLOPS when we multiply panel
460* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
461*
462* D**(-1) = ( d11 cj(d21) )**(-1) =
463* ( d21 d22 )
464*
465* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
466* ( (-d21) ( d11 ) )
467*
468* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
469*
470* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
471* ( ( -1 ) ( d11/conj(d21) ) )
472*
473* = 1/(|d21|**2) * 1/(D22*D11-1) *
474*
475* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
476* ( ( -1 ) ( D22 ) )
477*
478* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
479* ( ( -1 ) ( D22 ) )
480*
481* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
482* ( ( -1 ) ( D22 ) )
483*
484* = ( conj(D21)*( D11 ) D21*( -1 ) )
485* ( ( -1 ) ( D22 ) ),
486*
487* where D11 = d22/d21,
488* D22 = d11/conj(d21),
489* D21 = T/d21,
490* T = 1/(D22*D11-1).
491*
492* (NOTE: No need to check for division by ZERO,
493* since that was ensured earlier in pivot search:
494* (a) d21 != 0, since in 2x2 pivot case(4)
495* |d21| should be larger than |d11| and |d22|;
496* (b) (D22*D11 - 1) != 0, since from (a),
497* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
498*
499 d21 = w( k-1, kw )
500 d11 = w( k, kw ) / dconjg( d21 )
501 d22 = w( k-1, kw-1 ) / d21
502 t = one / ( dble( d11*d22 )-one )
503 d21 = t / d21
504*
505* Update elements in columns A(k-1) and A(k) as
506* dot products of rows of ( W(kw-1) W(kw) ) and columns
507* of D**(-1)
508*
509 DO 20 j = 1, k - 2
510 a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
511 a( j, k ) = dconjg( d21 )*
512 $ ( d22*w( j, kw )-w( j, kw-1 ) )
513 20 CONTINUE
514 END IF
515*
516* Copy D(k) to A
517*
518 a( k-1, k-1 ) = w( k-1, kw-1 )
519 a( k-1, k ) = w( k-1, kw )
520 a( k, k ) = w( k, kw )
521*
522* (2) Conjugate columns W(kw) and W(kw-1)
523*
524 CALL zlacgv( k-1, w( 1, kw ), 1 )
525 CALL zlacgv( k-2, w( 1, kw-1 ), 1 )
526*
527 END IF
528*
529 END IF
530*
531* Store details of the interchanges in IPIV
532*
533 IF( kstep.EQ.1 ) THEN
534 ipiv( k ) = kp
535 ELSE
536 ipiv( k ) = -kp
537 ipiv( k-1 ) = -kp
538 END IF
539*
540* Decrease K and return to the start of the main loop
541*
542 k = k - kstep
543 GO TO 10
544*
545 30 CONTINUE
546*
547* Update the upper triangle of A11 (= A(1:k,1:k)) as
548*
549* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
550*
551* computing blocks of NB columns at a time (note that conjg(W) is
552* actually stored)
553*
554 DO 50 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
555 jb = min( nb, k-j+1 )
556*
557* Update the upper triangle of the diagonal block
558*
559 DO 40 jj = j, j + jb - 1
560 a( jj, jj ) = dble( a( jj, jj ) )
561 CALL zgemv( 'No transpose', jj-j+1, n-k, -cone,
562 $ a( j, k+1 ), lda, w( jj, kw+1 ), ldw, cone,
563 $ a( j, jj ), 1 )
564 a( jj, jj ) = dble( a( jj, jj ) )
565 40 CONTINUE
566*
567* Update the rectangular superdiagonal block
568*
569 CALL zgemm( 'No transpose', 'Transpose', j-1, jb, n-k,
570 $ -cone, a( 1, k+1 ), lda, w( j, kw+1 ), ldw,
571 $ cone, a( 1, j ), lda )
572 50 CONTINUE
573*
574* Put U12 in standard form by partially undoing the interchanges
575* in columns k+1:n looping backwards from k+1 to n
576*
577 j = k + 1
578 60 CONTINUE
579*
580* Undo the interchanges (if any) of rows JJ and JP at each
581* step J
582*
583* (Here, J is a diagonal index)
584 jj = j
585 jp = ipiv( j )
586 IF( jp.LT.0 ) THEN
587 jp = -jp
588* (Here, J is a diagonal index)
589 j = j + 1
590 END IF
591* (NOTE: Here, J is used to determine row length. Length N-J+1
592* of the rows to swap back doesn't include diagonal element)
593 j = j + 1
594 IF( jp.NE.jj .AND. j.LE.n )
595 $ CALL zswap( n-j+1, a( jp, j ), lda, a( jj, j ), lda )
596 IF( j.LT.n )
597 $ GO TO 60
598*
599* Set KB to the number of columns factorized
600*
601 kb = n - k
602*
603 ELSE
604*
605* Factorize the leading columns of A using the lower triangle
606* of A and working forwards, and compute the matrix W = L21*D
607* for use in updating A22 (note that conjg(W) is actually stored)
608*
609* K is the main loop index, increasing from 1 in steps of 1 or 2
610*
611 k = 1
612 70 CONTINUE
613*
614* Exit from loop
615*
616 IF( ( k.GE.nb .AND. nb.LT.n ) .OR. k.GT.n )
617 $ GO TO 90
618*
619 kstep = 1
620*
621* Copy column K of A to column K of W and update it
622*
623 w( k, k ) = dble( a( k, k ) )
624 IF( k.LT.n )
625 $ CALL zcopy( n-k, a( k+1, k ), 1, w( k+1, k ), 1 )
626 CALL zgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ), lda,
627 $ w( k, 1 ), ldw, cone, w( k, k ), 1 )
628 w( k, k ) = dble( w( k, k ) )
629*
630* Determine rows and columns to be interchanged and whether
631* a 1-by-1 or 2-by-2 pivot block will be used
632*
633 absakk = abs( dble( w( k, k ) ) )
634*
635* IMAX is the row-index of the largest off-diagonal element in
636* column K, and COLMAX is its absolute value.
637* Determine both COLMAX and IMAX.
638*
639 IF( k.LT.n ) THEN
640 imax = k + izamax( n-k, w( k+1, k ), 1 )
641 colmax = cabs1( w( imax, k ) )
642 ELSE
643 colmax = zero
644 END IF
645*
646 IF( max( absakk, colmax ).EQ.zero ) THEN
647*
648* Column K is zero or underflow: set INFO and continue
649*
650 IF( info.EQ.0 )
651 $ info = k
652 kp = k
653 a( k, k ) = dble( a( k, k ) )
654 ELSE
655*
656* ============================================================
657*
658* BEGIN pivot search
659*
660* Case(1)
661 IF( absakk.GE.alpha*colmax ) THEN
662*
663* no interchange, use 1-by-1 pivot block
664*
665 kp = k
666 ELSE
667*
668* BEGIN pivot search along IMAX row
669*
670*
671* Copy column IMAX to column K+1 of W and update it
672*
673 CALL zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 )
674 CALL zlacgv( imax-k, w( k, k+1 ), 1 )
675 w( imax, k+1 ) = dble( a( imax, imax ) )
676 IF( imax.LT.n )
677 $ CALL zcopy( n-imax, a( imax+1, imax ), 1,
678 $ w( imax+1, k+1 ), 1 )
679 CALL zgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ),
680 $ lda, w( imax, 1 ), ldw, cone, w( k, k+1 ),
681 $ 1 )
682 w( imax, k+1 ) = dble( w( imax, k+1 ) )
683*
684* JMAX is the column-index of the largest off-diagonal
685* element in row IMAX, and ROWMAX is its absolute value.
686* Determine only ROWMAX.
687*
688 jmax = k - 1 + izamax( imax-k, w( k, k+1 ), 1 )
689 rowmax = cabs1( w( jmax, k+1 ) )
690 IF( imax.LT.n ) THEN
691 jmax = imax + izamax( n-imax, w( imax+1, k+1 ), 1 )
692 rowmax = max( rowmax, cabs1( w( jmax, k+1 ) ) )
693 END IF
694*
695* Case(2)
696 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
697*
698* no interchange, use 1-by-1 pivot block
699*
700 kp = k
701*
702* Case(3)
703 ELSE IF( abs( dble( w( imax, k+1 ) ) ).GE.alpha*rowmax )
704 $ THEN
705*
706* interchange rows and columns K and IMAX, use 1-by-1
707* pivot block
708*
709 kp = imax
710*
711* copy column K+1 of W to column K of W
712*
713 CALL zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
714*
715* Case(4)
716 ELSE
717*
718* interchange rows and columns K+1 and IMAX, use 2-by-2
719* pivot block
720*
721 kp = imax
722 kstep = 2
723 END IF
724*
725*
726* END pivot search along IMAX row
727*
728 END IF
729*
730* END pivot search
731*
732* ============================================================
733*
734* KK is the column of A where pivoting step stopped
735*
736 kk = k + kstep - 1
737*
738* Interchange rows and columns KP and KK.
739* Updated column KP is already stored in column KK of W.
740*
741 IF( kp.NE.kk ) THEN
742*
743* Copy non-updated column KK to column KP of submatrix A
744* at step K. No need to copy element into column K
745* (or K and K+1 for 2-by-2 pivot) of A, since these columns
746* will be later overwritten.
747*
748 a( kp, kp ) = dble( a( kk, kk ) )
749 CALL zcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
750 $ lda )
751 CALL zlacgv( kp-kk-1, a( kp, kk+1 ), lda )
752 IF( kp.LT.n )
753 $ CALL zcopy( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
754*
755* Interchange rows KK and KP in first K-1 columns of A
756* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
757* later overwritten). Interchange rows KK and KP
758* in first KK columns of W.
759*
760 IF( k.GT.1 )
761 $ CALL zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
762 CALL zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw )
763 END IF
764*
765 IF( kstep.EQ.1 ) THEN
766*
767* 1-by-1 pivot block D(k): column k of W now holds
768*
769* W(k) = L(k)*D(k),
770*
771* where L(k) is the k-th column of L
772*
773* (1) Store subdiag. elements of column L(k)
774* and 1-by-1 block D(k) in column k of A.
775* (NOTE: Diagonal element L(k,k) is a UNIT element
776* and not stored)
777* A(k,k) := D(k,k) = W(k,k)
778* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
779*
780* (NOTE: No need to use for Hermitian matrix
781* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
782* element D(k,k) from W (potentially saves only one load))
783 CALL zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
784 IF( k.LT.n ) THEN
785*
786* (NOTE: No need to check if A(k,k) is NOT ZERO,
787* since that was ensured earlier in pivot search:
788* case A(k,k) = 0 falls into 2x2 pivot case(4))
789*
790 r1 = one / dble( a( k, k ) )
791 CALL zdscal( n-k, r1, a( k+1, k ), 1 )
792*
793* (2) Conjugate column W(k)
794*
795 CALL zlacgv( n-k, w( k+1, k ), 1 )
796 END IF
797*
798 ELSE
799*
800* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
801*
802* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
803*
804* where L(k) and L(k+1) are the k-th and (k+1)-th columns
805* of L
806*
807* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
808* block D(k:k+1,k:k+1) in columns k and k+1 of A.
809* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
810* block and not stored)
811* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
812* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
813* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
814*
815 IF( k.LT.n-1 ) THEN
816*
817* Factor out the columns of the inverse of 2-by-2 pivot
818* block D, so that each column contains 1, to reduce the
819* number of FLOPS when we multiply panel
820* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
821*
822* D**(-1) = ( d11 cj(d21) )**(-1) =
823* ( d21 d22 )
824*
825* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
826* ( (-d21) ( d11 ) )
827*
828* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
829*
830* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
831* ( ( -1 ) ( d11/conj(d21) ) )
832*
833* = 1/(|d21|**2) * 1/(D22*D11-1) *
834*
835* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
836* ( ( -1 ) ( D22 ) )
837*
838* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
839* ( ( -1 ) ( D22 ) )
840*
841* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
842* ( ( -1 ) ( D22 ) )
843*
844* = ( conj(D21)*( D11 ) D21*( -1 ) )
845* ( ( -1 ) ( D22 ) ),
846*
847* where D11 = d22/d21,
848* D22 = d11/conj(d21),
849* D21 = T/d21,
850* T = 1/(D22*D11-1).
851*
852* (NOTE: No need to check for division by ZERO,
853* since that was ensured earlier in pivot search:
854* (a) d21 != 0, since in 2x2 pivot case(4)
855* |d21| should be larger than |d11| and |d22|;
856* (b) (D22*D11 - 1) != 0, since from (a),
857* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
858*
859 d21 = w( k+1, k )
860 d11 = w( k+1, k+1 ) / d21
861 d22 = w( k, k ) / dconjg( d21 )
862 t = one / ( dble( d11*d22 )-one )
863 d21 = t / d21
864*
865* Update elements in columns A(k) and A(k+1) as
866* dot products of rows of ( W(k) W(k+1) ) and columns
867* of D**(-1)
868*
869 DO 80 j = k + 2, n
870 a( j, k ) = dconjg( d21 )*
871 $ ( d11*w( j, k )-w( j, k+1 ) )
872 a( j, k+1 ) = d21*( d22*w( j, k+1 )-w( j, k ) )
873 80 CONTINUE
874 END IF
875*
876* Copy D(k) to A
877*
878 a( k, k ) = w( k, k )
879 a( k+1, k ) = w( k+1, k )
880 a( k+1, k+1 ) = w( k+1, k+1 )
881*
882* (2) Conjugate columns W(k) and W(k+1)
883*
884 CALL zlacgv( n-k, w( k+1, k ), 1 )
885 CALL zlacgv( n-k-1, w( k+2, k+1 ), 1 )
886*
887 END IF
888*
889 END IF
890*
891* Store details of the interchanges in IPIV
892*
893 IF( kstep.EQ.1 ) THEN
894 ipiv( k ) = kp
895 ELSE
896 ipiv( k ) = -kp
897 ipiv( k+1 ) = -kp
898 END IF
899*
900* Increase K and return to the start of the main loop
901*
902 k = k + kstep
903 GO TO 70
904*
905 90 CONTINUE
906*
907* Update the lower triangle of A22 (= A(k:n,k:n)) as
908*
909* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
910*
911* computing blocks of NB columns at a time (note that conjg(W) is
912* actually stored)
913*
914 DO 110 j = k, n, nb
915 jb = min( nb, n-j+1 )
916*
917* Update the lower triangle of the diagonal block
918*
919 DO 100 jj = j, j + jb - 1
920 a( jj, jj ) = dble( a( jj, jj ) )
921 CALL zgemv( 'No transpose', j+jb-jj, k-1, -cone,
922 $ a( jj, 1 ), lda, w( jj, 1 ), ldw, cone,
923 $ a( jj, jj ), 1 )
924 a( jj, jj ) = dble( a( jj, jj ) )
925 100 CONTINUE
926*
927* Update the rectangular subdiagonal block
928*
929 IF( j+jb.LE.n )
930 $ CALL zgemm( 'No transpose', 'Transpose', n-j-jb+1, jb,
931 $ k-1, -cone, a( j+jb, 1 ), lda, w( j, 1 ),
932 $ ldw, cone, a( j+jb, j ), lda )
933 110 CONTINUE
934*
935* Put L21 in standard form by partially undoing the interchanges
936* of rows in columns 1:k-1 looping backwards from k-1 to 1
937*
938 j = k - 1
939 120 CONTINUE
940*
941* Undo the interchanges (if any) of rows JJ and JP at each
942* step J
943*
944* (Here, J is a diagonal index)
945 jj = j
946 jp = ipiv( j )
947 IF( jp.LT.0 ) THEN
948 jp = -jp
949* (Here, J is a diagonal index)
950 j = j - 1
951 END IF
952* (NOTE: Here, J is used to determine row length. Length J
953* of the rows to swap back doesn't include diagonal element)
954 j = j - 1
955 IF( jp.NE.jj .AND. j.GE.1 )
956 $ CALL zswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda )
957 IF( j.GT.1 )
958 $ GO TO 120
959*
960* Set KB to the number of columns factorized
961*
962 kb = k - 1
963*
964 END IF
965 RETURN
966*
967* End of ZLAHEF
968*

◆ zlahef_aa()

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

ZLAHEF_AA

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

Purpose:
!>
!> DLAHEF_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 ZHETRF_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*16 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*16 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*16 workspace, dimension (M).
!> 
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file zlahef_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*16 A( LDA, * ), H( LDH, * ), WORK( * )
158* ..
159*
160* =====================================================================
161* .. Parameters ..
162 COMPLEX*16 ZERO, ONE
163 parameter( zero = (0.0d+0, 0.0d+0), one = (1.0d+0, 0.0d+0) )
164*
165* .. Local Scalars ..
166 INTEGER J, K, K1, I1, I2, MJ
167 COMPLEX*16 PIV, ALPHA
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER IZAMAX, ILAENV
172 EXTERNAL lsame, ilaenv, izamax
173* ..
174* .. External Subroutines ..
175 EXTERNAL zgemm, zgemv, zaxpy, zlacgv, zcopy, zscal, zswap,
176 $ zlaset, xerbla
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC dble, dconjg, 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 ZHETRF_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 zlacgv( j-k1, a( 1, j ), 1 )
227 CALL zgemv( 'No transpose', mj, j-k1,
228 $ -one, h( j, k1 ), ldh,
229 $ a( 1, j ), 1,
230 $ one, h( j, j ), 1 )
231 CALL zlacgv( j-k1, a( 1, j ), 1 )
232 END IF
233*
234* Copy H(i:n, i) into WORK
235*
236 CALL zcopy( 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 = -dconjg( a( k-1, j ) )
244 CALL zaxpy( 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 ) = dble( 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 zaxpy( 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 = izamax( 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 zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,
282 $ a( j1+i1, i2 ), 1 )
283 CALL zlacgv( i2-i1, a( j1+i1-1, i1+1 ), lda )
284 CALL zlacgv( 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 zswap( 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 zswap( 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 zswap( 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 zcopy( 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 zcopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
334 CALL zscal( m-j-1, alpha, a( k, j+2 ), lda )
335 ELSE
336 CALL zlaset( '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 ZHETRF_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 zlacgv( j-k1, a( j, 1 ), lda )
382 CALL zgemv( 'No transpose', mj, j-k1,
383 $ -one, h( j, k1 ), ldh,
384 $ a( j, 1 ), lda,
385 $ one, h( j, j ), 1 )
386 CALL zlacgv( j-k1, a( j, 1 ), lda )
387 END IF
388*
389* Copy H(J:N, J) into WORK
390*
391 CALL zcopy( 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 = -dconjg( a( j, k-1 ) )
399 CALL zaxpy( 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 ) = dble( 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 zaxpy( 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 = izamax( 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 zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,
437 $ a( i2, j1+i1 ), lda )
438 CALL zlacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 )
439 CALL zlacgv( 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 zswap( 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 zswap( 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 zswap( 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 zcopy( 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 zcopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
489 CALL zscal( m-j-1, alpha, a( j+2, k ), 1 )
490 ELSE
491 CALL zlaset( '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 ZLAHEF_AA
503*

◆ zlahef_rk()

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

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

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

Purpose:
!> ZLAHEF_RK computes a partial factorization of a complex Hermitian
!> 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**H U22**H )
!>
!> A  =  ( L11  0 ) (  D   0  ) ( L11**H L21**H )  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.
!>
!> ZLAHEF_RK is an auxiliary routine called by ZHETRF_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
!>          Hermitian 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*16 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, contains:
!>            a) ONLY diagonal elements of the Hermitian 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*16 array, dimension (N)
!>          On exit, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian 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 Hermitian 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*16 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 zlahef_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*16 A( LDA, * ), W( LDW, * ), E( * )
274* ..
275*
276* =====================================================================
277*
278* .. Parameters ..
279 DOUBLE PRECISION ZERO, ONE
280 parameter( zero = 0.0d+0, one = 1.0d+0 )
281 COMPLEX*16 CONE
282 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
283 DOUBLE PRECISION EIGHT, SEVTEN
284 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
285 COMPLEX*16 CZERO
286 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
287* ..
288* .. Local Scalars ..
289 LOGICAL DONE
290 INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, K, KK, KKW,
291 $ KP, KSTEP, KW, P
292 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, DTEMP, R1, ROWMAX, T,
293 $ SFMIN
294 COMPLEX*16 D11, D21, D22, Z
295* ..
296* .. External Functions ..
297 LOGICAL LSAME
298 INTEGER IZAMAX
299 DOUBLE PRECISION DLAMCH
300 EXTERNAL lsame, izamax, dlamch
301* ..
302* .. External Subroutines ..
303 EXTERNAL zcopy, zdscal, zgemm, zgemv, zlacgv, zswap
304* ..
305* .. Intrinsic Functions ..
306 INTRINSIC abs, dble, dconjg, dimag, max, min, sqrt
307* ..
308* .. Statement Functions ..
309 DOUBLE PRECISION CABS1
310* ..
311* .. Statement Function definitions ..
312 cabs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
313* ..
314* .. Executable Statements ..
315*
316 info = 0
317*
318* Initialize ALPHA for use in choosing pivot block size.
319*
320 alpha = ( one+sqrt( sevten ) ) / eight
321*
322* Compute machine safe minimum
323*
324 sfmin = dlamch( 'S' )
325*
326 IF( lsame( uplo, 'U' ) ) THEN
327*
328* Factorize the trailing columns of A using the upper triangle
329* of A and working backwards, and compute the matrix W = U12*D
330* for use in updating A11 (note that conjg(W) is actually stored)
331* Initialize the first entry of array E, where superdiagonal
332* elements of D are stored
333*
334 e( 1 ) = czero
335*
336* K is the main loop index, decreasing from N in steps of 1 or 2
337*
338 k = n
339 10 CONTINUE
340*
341* KW is the column of W which corresponds to column K of A
342*
343 kw = nb + k - n
344*
345* Exit from loop
346*
347 IF( ( k.LE.n-nb+1 .AND. nb.LT.n ) .OR. k.LT.1 )
348 $ GO TO 30
349*
350 kstep = 1
351 p = k
352*
353* Copy column K of A to column KW of W and update it
354*
355 IF( k.GT.1 )
356 $ CALL zcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 )
357 w( k, kw ) = dble( a( k, k ) )
358 IF( k.LT.n ) THEN
359 CALL zgemv( 'No transpose', k, n-k, -cone, a( 1, k+1 ), lda,
360 $ w( k, kw+1 ), ldw, cone, w( 1, kw ), 1 )
361 w( k, kw ) = dble( w( k, kw ) )
362 END IF
363*
364* Determine rows and columns to be interchanged and whether
365* a 1-by-1 or 2-by-2 pivot block will be used
366*
367 absakk = abs( dble( w( k, kw ) ) )
368*
369* IMAX is the row-index of the largest off-diagonal element in
370* column K, and COLMAX is its absolute value.
371* Determine both COLMAX and IMAX.
372*
373 IF( k.GT.1 ) THEN
374 imax = izamax( k-1, w( 1, kw ), 1 )
375 colmax = cabs1( w( imax, kw ) )
376 ELSE
377 colmax = zero
378 END IF
379*
380 IF( max( absakk, colmax ).EQ.zero ) THEN
381*
382* Column K is zero or underflow: set INFO and continue
383*
384 IF( info.EQ.0 )
385 $ info = k
386 kp = k
387 a( k, k ) = dble( w( k, kw ) )
388 IF( k.GT.1 )
389 $ CALL zcopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 )
390*
391* Set E( K ) to zero
392*
393 IF( k.GT.1 )
394 $ e( k ) = czero
395*
396 ELSE
397*
398* ============================================================
399*
400* BEGIN pivot search
401*
402* Case(1)
403* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
404* (used to handle NaN and Inf)
405 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
406*
407* no interchange, use 1-by-1 pivot block
408*
409 kp = k
410*
411 ELSE
412*
413* Lop until pivot found
414*
415 done = .false.
416*
417 12 CONTINUE
418*
419* BEGIN pivot search loop body
420*
421*
422* Copy column IMAX to column KW-1 of W and update it
423*
424 IF( imax.GT.1 )
425 $ CALL zcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),
426 $ 1 )
427 w( imax, kw-1 ) = dble( a( imax, imax ) )
428*
429 CALL zcopy( k-imax, a( imax, imax+1 ), lda,
430 $ w( imax+1, kw-1 ), 1 )
431 CALL zlacgv( k-imax, w( imax+1, kw-1 ), 1 )
432*
433 IF( k.LT.n ) THEN
434 CALL zgemv( 'No transpose', k, n-k, -cone,
435 $ a( 1, k+1 ), lda, w( imax, kw+1 ), ldw,
436 $ cone, w( 1, kw-1 ), 1 )
437 w( imax, kw-1 ) = dble( w( imax, kw-1 ) )
438 END IF
439*
440* JMAX is the column-index of the largest off-diagonal
441* element in row IMAX, and ROWMAX is its absolute value.
442* Determine both ROWMAX and JMAX.
443*
444 IF( imax.NE.k ) THEN
445 jmax = imax + izamax( k-imax, w( imax+1, kw-1 ),
446 $ 1 )
447 rowmax = cabs1( w( jmax, kw-1 ) )
448 ELSE
449 rowmax = zero
450 END IF
451*
452 IF( imax.GT.1 ) THEN
453 itemp = izamax( imax-1, w( 1, kw-1 ), 1 )
454 dtemp = cabs1( w( itemp, kw-1 ) )
455 IF( dtemp.GT.rowmax ) THEN
456 rowmax = dtemp
457 jmax = itemp
458 END IF
459 END IF
460*
461* Case(2)
462* Equivalent to testing for
463* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
464* (used to handle NaN and Inf)
465*
466 IF( .NOT.( abs( dble( w( imax,kw-1 ) ) )
467 $ .LT.alpha*rowmax ) ) THEN
468*
469* interchange rows and columns K and IMAX,
470* use 1-by-1 pivot block
471*
472 kp = imax
473*
474* copy column KW-1 of W to column KW of W
475*
476 CALL zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
477*
478 done = .true.
479*
480* Case(3)
481* Equivalent to testing for ROWMAX.EQ.COLMAX,
482* (used to handle NaN and Inf)
483*
484 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
485 $ THEN
486*
487* interchange rows and columns K-1 and IMAX,
488* use 2-by-2 pivot block
489*
490 kp = imax
491 kstep = 2
492 done = .true.
493*
494* Case(4)
495 ELSE
496*
497* Pivot not found: set params and repeat
498*
499 p = imax
500 colmax = rowmax
501 imax = jmax
502*
503* Copy updated JMAXth (next IMAXth) column to Kth of W
504*
505 CALL zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
506*
507 END IF
508*
509*
510* END pivot search loop body
511*
512 IF( .NOT.done ) GOTO 12
513*
514 END IF
515*
516* END pivot search
517*
518* ============================================================
519*
520* KK is the column of A where pivoting step stopped
521*
522 kk = k - kstep + 1
523*
524* KKW is the column of W which corresponds to column KK of A
525*
526 kkw = nb + kk - n
527*
528* Interchange rows and columns P and K.
529* Updated column P is already stored in column KW of W.
530*
531 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
532*
533* Copy non-updated column K to column P of submatrix A
534* at step K. No need to copy element into columns
535* K and K-1 of A for 2-by-2 pivot, since these columns
536* will be later overwritten.
537*
538 a( p, p ) = dble( a( k, k ) )
539 CALL zcopy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),
540 $ lda )
541 CALL zlacgv( k-1-p, a( p, p+1 ), lda )
542 IF( p.GT.1 )
543 $ CALL zcopy( p-1, a( 1, k ), 1, a( 1, p ), 1 )
544*
545* Interchange rows K and P in the last K+1 to N columns of A
546* (columns K and K-1 of A for 2-by-2 pivot will be
547* later overwritten). Interchange rows K and P
548* in last KKW to NB columns of W.
549*
550 IF( k.LT.n )
551 $ CALL zswap( n-k, a( k, k+1 ), lda, a( p, k+1 ),
552 $ lda )
553 CALL zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ),
554 $ ldw )
555 END IF
556*
557* Interchange rows and columns KP and KK.
558* Updated column KP is already stored in column KKW of W.
559*
560 IF( kp.NE.kk ) THEN
561*
562* Copy non-updated column KK to column KP of submatrix A
563* at step K. No need to copy element into column K
564* (or K and K-1 for 2-by-2 pivot) of A, since these columns
565* will be later overwritten.
566*
567 a( kp, kp ) = dble( a( kk, kk ) )
568 CALL zcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
569 $ lda )
570 CALL zlacgv( kk-1-kp, a( kp, kp+1 ), lda )
571 IF( kp.GT.1 )
572 $ CALL zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
573*
574* Interchange rows KK and KP in last K+1 to N columns of A
575* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
576* later overwritten). Interchange rows KK and KP
577* in last KKW to NB columns of W.
578*
579 IF( k.LT.n )
580 $ CALL zswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
581 $ lda )
582 CALL zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),
583 $ ldw )
584 END IF
585*
586 IF( kstep.EQ.1 ) THEN
587*
588* 1-by-1 pivot block D(k): column kw of W now holds
589*
590* W(kw) = U(k)*D(k),
591*
592* where U(k) is the k-th column of U
593*
594* (1) Store subdiag. elements of column U(k)
595* and 1-by-1 block D(k) in column k of A.
596* (NOTE: Diagonal element U(k,k) is a UNIT element
597* and not stored)
598* A(k,k) := D(k,k) = W(k,kw)
599* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
600*
601* (NOTE: No need to use for Hermitian matrix
602* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
603* element D(k,k) from W (potentially saves only one load))
604 CALL zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
605 IF( k.GT.1 ) THEN
606*
607* (NOTE: No need to check if A(k,k) is NOT ZERO,
608* since that was ensured earlier in pivot search:
609* case A(k,k) = 0 falls into 2x2 pivot case(3))
610*
611* Handle division by a small number
612*
613 t = dble( a( k, k ) )
614 IF( abs( t ).GE.sfmin ) THEN
615 r1 = one / t
616 CALL zdscal( k-1, r1, a( 1, k ), 1 )
617 ELSE
618 DO 14 ii = 1, k-1
619 a( ii, k ) = a( ii, k ) / t
620 14 CONTINUE
621 END IF
622*
623* (2) Conjugate column W(kw)
624*
625 CALL zlacgv( k-1, w( 1, kw ), 1 )
626*
627* Store the superdiagonal element of D in array E
628*
629 e( k ) = czero
630*
631 END IF
632*
633 ELSE
634*
635* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
636*
637* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
638*
639* where U(k) and U(k-1) are the k-th and (k-1)-th columns
640* of U
641*
642* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
643* block D(k-1:k,k-1:k) in columns k-1 and k of A.
644* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
645* block and not stored)
646* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
647* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
648* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
649*
650 IF( k.GT.2 ) THEN
651*
652* Factor out the columns of the inverse of 2-by-2 pivot
653* block D, so that each column contains 1, to reduce the
654* number of FLOPS when we multiply panel
655* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
656*
657* D**(-1) = ( d11 cj(d21) )**(-1) =
658* ( d21 d22 )
659*
660* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
661* ( (-d21) ( d11 ) )
662*
663* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
664*
665* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
666* ( ( -1 ) ( d11/conj(d21) ) )
667*
668* = 1/(|d21|**2) * 1/(D22*D11-1) *
669*
670* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
671* ( ( -1 ) ( D22 ) )
672*
673* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
674* ( ( -1 ) ( D22 ) )
675*
676* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
677* ( ( -1 ) ( D22 ) )
678*
679* Handle division by a small number. (NOTE: order of
680* operations is important)
681*
682* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
683* ( (( -1 ) ) (( D22 ) ) ),
684*
685* where D11 = d22/d21,
686* D22 = d11/conj(d21),
687* D21 = d21,
688* T = 1/(D22*D11-1).
689*
690* (NOTE: No need to check for division by ZERO,
691* since that was ensured earlier in pivot search:
692* (a) d21 != 0 in 2x2 pivot case(4),
693* since |d21| should be larger than |d11| and |d22|;
694* (b) (D22*D11 - 1) != 0, since from (a),
695* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
696*
697 d21 = w( k-1, kw )
698 d11 = w( k, kw ) / dconjg( d21 )
699 d22 = w( k-1, kw-1 ) / d21
700 t = one / ( dble( d11*d22 )-one )
701*
702* Update elements in columns A(k-1) and A(k) as
703* dot products of rows of ( W(kw-1) W(kw) ) and columns
704* of D**(-1)
705*
706 DO 20 j = 1, k - 2
707 a( j, k-1 ) = t*( ( d11*w( j, kw-1 )-w( j, kw ) ) /
708 $ d21 )
709 a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /
710 $ dconjg( d21 ) )
711 20 CONTINUE
712 END IF
713*
714* Copy diagonal elements of D(K) to A,
715* copy superdiagonal element of D(K) to E(K) and
716* ZERO out superdiagonal entry of A
717*
718 a( k-1, k-1 ) = w( k-1, kw-1 )
719 a( k-1, k ) = czero
720 a( k, k ) = w( k, kw )
721 e( k ) = w( k-1, kw )
722 e( k-1 ) = czero
723*
724* (2) Conjugate columns W(kw) and W(kw-1)
725*
726 CALL zlacgv( k-1, w( 1, kw ), 1 )
727 CALL zlacgv( k-2, w( 1, kw-1 ), 1 )
728*
729 END IF
730*
731* End column K is nonsingular
732*
733 END IF
734*
735* Store details of the interchanges in IPIV
736*
737 IF( kstep.EQ.1 ) THEN
738 ipiv( k ) = kp
739 ELSE
740 ipiv( k ) = -p
741 ipiv( k-1 ) = -kp
742 END IF
743*
744* Decrease K and return to the start of the main loop
745*
746 k = k - kstep
747 GO TO 10
748*
749 30 CONTINUE
750*
751* Update the upper triangle of A11 (= A(1:k,1:k)) as
752*
753* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
754*
755* computing blocks of NB columns at a time (note that conjg(W) is
756* actually stored)
757*
758 DO 50 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
759 jb = min( nb, k-j+1 )
760*
761* Update the upper triangle of the diagonal block
762*
763 DO 40 jj = j, j + jb - 1
764 a( jj, jj ) = dble( a( jj, jj ) )
765 CALL zgemv( 'No transpose', jj-j+1, n-k, -cone,
766 $ a( j, k+1 ), lda, w( jj, kw+1 ), ldw, cone,
767 $ a( j, jj ), 1 )
768 a( jj, jj ) = dble( a( jj, jj ) )
769 40 CONTINUE
770*
771* Update the rectangular superdiagonal block
772*
773 IF( j.GE.2 )
774 $ CALL zgemm( 'No transpose', 'Transpose', j-1, jb, n-k,
775 $ -cone, a( 1, k+1 ), lda, w( j, kw+1 ), ldw,
776 $ cone, a( 1, j ), lda )
777 50 CONTINUE
778*
779* Set KB to the number of columns factorized
780*
781 kb = n - k
782*
783 ELSE
784*
785* Factorize the leading columns of A using the lower triangle
786* of A and working forwards, and compute the matrix W = L21*D
787* for use in updating A22 (note that conjg(W) is actually stored)
788*
789* Initialize the unused last entry of the subdiagonal array E.
790*
791 e( n ) = czero
792*
793* K is the main loop index, increasing from 1 in steps of 1 or 2
794*
795 k = 1
796 70 CONTINUE
797*
798* Exit from loop
799*
800 IF( ( k.GE.nb .AND. nb.LT.n ) .OR. k.GT.n )
801 $ GO TO 90
802*
803 kstep = 1
804 p = k
805*
806* Copy column K of A to column K of W and update column K of W
807*
808 w( k, k ) = dble( a( k, k ) )
809 IF( k.LT.n )
810 $ CALL zcopy( n-k, a( k+1, k ), 1, w( k+1, k ), 1 )
811 IF( k.GT.1 ) THEN
812 CALL zgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ),
813 $ lda, w( k, 1 ), ldw, cone, w( k, k ), 1 )
814 w( k, k ) = dble( w( k, k ) )
815 END IF
816*
817* Determine rows and columns to be interchanged and whether
818* a 1-by-1 or 2-by-2 pivot block will be used
819*
820 absakk = abs( dble( w( k, k ) ) )
821*
822* IMAX is the row-index of the largest off-diagonal element in
823* column K, and COLMAX is its absolute value.
824* Determine both COLMAX and IMAX.
825*
826 IF( k.LT.n ) THEN
827 imax = k + izamax( n-k, w( k+1, k ), 1 )
828 colmax = cabs1( w( imax, k ) )
829 ELSE
830 colmax = zero
831 END IF
832*
833 IF( max( absakk, colmax ).EQ.zero ) THEN
834*
835* Column K is zero or underflow: set INFO and continue
836*
837 IF( info.EQ.0 )
838 $ info = k
839 kp = k
840 a( k, k ) = dble( w( k, k ) )
841 IF( k.LT.n )
842 $ CALL zcopy( n-k, w( k+1, k ), 1, a( k+1, k ), 1 )
843*
844* Set E( K ) to zero
845*
846 IF( k.LT.n )
847 $ e( k ) = czero
848*
849 ELSE
850*
851* ============================================================
852*
853* BEGIN pivot search
854*
855* Case(1)
856* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
857* (used to handle NaN and Inf)
858*
859 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
860*
861* no interchange, use 1-by-1 pivot block
862*
863 kp = k
864*
865 ELSE
866*
867 done = .false.
868*
869* Loop until pivot found
870*
871 72 CONTINUE
872*
873* BEGIN pivot search loop body
874*
875*
876* Copy column IMAX to column k+1 of W and update it
877*
878 CALL zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1)
879 CALL zlacgv( imax-k, w( k, k+1 ), 1 )
880 w( imax, k+1 ) = dble( a( imax, imax ) )
881*
882 IF( imax.LT.n )
883 $ CALL zcopy( n-imax, a( imax+1, imax ), 1,
884 $ w( imax+1, k+1 ), 1 )
885*
886 IF( k.GT.1 ) THEN
887 CALL zgemv( 'No transpose', n-k+1, k-1, -cone,
888 $ a( k, 1 ), lda, w( imax, 1 ), ldw,
889 $ cone, w( k, k+1 ), 1 )
890 w( imax, k+1 ) = dble( w( imax, k+1 ) )
891 END IF
892*
893* JMAX is the column-index of the largest off-diagonal
894* element in row IMAX, and ROWMAX is its absolute value.
895* Determine both ROWMAX and JMAX.
896*
897 IF( imax.NE.k ) THEN
898 jmax = k - 1 + izamax( imax-k, w( k, k+1 ), 1 )
899 rowmax = cabs1( w( jmax, k+1 ) )
900 ELSE
901 rowmax = zero
902 END IF
903*
904 IF( imax.LT.n ) THEN
905 itemp = imax + izamax( n-imax, w( imax+1, k+1 ), 1)
906 dtemp = cabs1( w( itemp, k+1 ) )
907 IF( dtemp.GT.rowmax ) THEN
908 rowmax = dtemp
909 jmax = itemp
910 END IF
911 END IF
912*
913* Case(2)
914* Equivalent to testing for
915* ABS( DBLE( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX
916* (used to handle NaN and Inf)
917*
918 IF( .NOT.( abs( dble( w( imax,k+1 ) ) )
919 $ .LT.alpha*rowmax ) ) THEN
920*
921* interchange rows and columns K and IMAX,
922* use 1-by-1 pivot block
923*
924 kp = imax
925*
926* copy column K+1 of W to column K of W
927*
928 CALL zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
929*
930 done = .true.
931*
932* Case(3)
933* Equivalent to testing for ROWMAX.EQ.COLMAX,
934* (used to handle NaN and Inf)
935*
936 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
937 $ THEN
938*
939* interchange rows and columns K+1 and IMAX,
940* use 2-by-2 pivot block
941*
942 kp = imax
943 kstep = 2
944 done = .true.
945*
946* Case(4)
947 ELSE
948*
949* Pivot not found: set params and repeat
950*
951 p = imax
952 colmax = rowmax
953 imax = jmax
954*
955* Copy updated JMAXth (next IMAXth) column to Kth of W
956*
957 CALL zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
958*
959 END IF
960*
961*
962* End pivot search loop body
963*
964 IF( .NOT.done ) GOTO 72
965*
966 END IF
967*
968* END pivot search
969*
970* ============================================================
971*
972* KK is the column of A where pivoting step stopped
973*
974 kk = k + kstep - 1
975*
976* Interchange rows and columns P and K (only for 2-by-2 pivot).
977* Updated column P is already stored in column K of W.
978*
979 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
980*
981* Copy non-updated column KK-1 to column P of submatrix A
982* at step K. No need to copy element into columns
983* K and K+1 of A for 2-by-2 pivot, since these columns
984* will be later overwritten.
985*
986 a( p, p ) = dble( a( k, k ) )
987 CALL zcopy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda )
988 CALL zlacgv( p-k-1, a( p, k+1 ), lda )
989 IF( p.LT.n )
990 $ CALL zcopy( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
991*
992* Interchange rows K and P in first K-1 columns of A
993* (columns K and K+1 of A for 2-by-2 pivot will be
994* later overwritten). Interchange rows K and P
995* in first KK columns of W.
996*
997 IF( k.GT.1 )
998 $ CALL zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda )
999 CALL zswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw )
1000 END IF
1001*
1002* Interchange rows and columns KP and KK.
1003* Updated column KP is already stored in column KK of W.
1004*
1005 IF( kp.NE.kk ) THEN
1006*
1007* Copy non-updated column KK to column KP of submatrix A
1008* at step K. No need to copy element into column K
1009* (or K and K+1 for 2-by-2 pivot) of A, since these columns
1010* will be later overwritten.
1011*
1012 a( kp, kp ) = dble( a( kk, kk ) )
1013 CALL zcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
1014 $ lda )
1015 CALL zlacgv( kp-kk-1, a( kp, kk+1 ), lda )
1016 IF( kp.LT.n )
1017 $ CALL zcopy( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
1018*
1019* Interchange rows KK and KP in first K-1 columns of A
1020* (column K (or K and K+1 for 2-by-2 pivot) of A will be
1021* later overwritten). Interchange rows KK and KP
1022* in first KK columns of W.
1023*
1024 IF( k.GT.1 )
1025 $ CALL zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
1026 CALL zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw )
1027 END IF
1028*
1029 IF( kstep.EQ.1 ) THEN
1030*
1031* 1-by-1 pivot block D(k): column k of W now holds
1032*
1033* W(k) = L(k)*D(k),
1034*
1035* where L(k) is the k-th column of L
1036*
1037* (1) Store subdiag. elements of column L(k)
1038* and 1-by-1 block D(k) in column k of A.
1039* (NOTE: Diagonal element L(k,k) is a UNIT element
1040* and not stored)
1041* A(k,k) := D(k,k) = W(k,k)
1042* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
1043*
1044* (NOTE: No need to use for Hermitian matrix
1045* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
1046* element D(k,k) from W (potentially saves only one load))
1047 CALL zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
1048 IF( k.LT.n ) THEN
1049*
1050* (NOTE: No need to check if A(k,k) is NOT ZERO,
1051* since that was ensured earlier in pivot search:
1052* case A(k,k) = 0 falls into 2x2 pivot case(3))
1053*
1054* Handle division by a small number
1055*
1056 t = dble( a( k, k ) )
1057 IF( abs( t ).GE.sfmin ) THEN
1058 r1 = one / t
1059 CALL zdscal( n-k, r1, a( k+1, k ), 1 )
1060 ELSE
1061 DO 74 ii = k + 1, n
1062 a( ii, k ) = a( ii, k ) / t
1063 74 CONTINUE
1064 END IF
1065*
1066* (2) Conjugate column W(k)
1067*
1068 CALL zlacgv( n-k, w( k+1, k ), 1 )
1069*
1070* Store the subdiagonal element of D in array E
1071*
1072 e( k ) = czero
1073*
1074 END IF
1075*
1076 ELSE
1077*
1078* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
1079*
1080* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
1081*
1082* where L(k) and L(k+1) are the k-th and (k+1)-th columns
1083* of L
1084*
1085* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
1086* block D(k:k+1,k:k+1) in columns k and k+1 of A.
1087* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
1088* block and not stored.
1089* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
1090* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
1091* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
1092*
1093 IF( k.LT.n-1 ) THEN
1094*
1095* Factor out the columns of the inverse of 2-by-2 pivot
1096* block D, so that each column contains 1, to reduce the
1097* number of FLOPS when we multiply panel
1098* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
1099*
1100* D**(-1) = ( d11 cj(d21) )**(-1) =
1101* ( d21 d22 )
1102*
1103* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
1104* ( (-d21) ( d11 ) )
1105*
1106* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
1107*
1108* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
1109* ( ( -1 ) ( d11/conj(d21) ) )
1110*
1111* = 1/(|d21|**2) * 1/(D22*D11-1) *
1112*
1113* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
1114* ( ( -1 ) ( D22 ) )
1115*
1116* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
1117* ( ( -1 ) ( D22 ) )
1118*
1119* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
1120* ( ( -1 ) ( D22 ) )
1121*
1122* Handle division by a small number. (NOTE: order of
1123* operations is important)
1124*
1125* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
1126* ( (( -1 ) ) (( D22 ) ) ),
1127*
1128* where D11 = d22/d21,
1129* D22 = d11/conj(d21),
1130* D21 = d21,
1131* T = 1/(D22*D11-1).
1132*
1133* (NOTE: No need to check for division by ZERO,
1134* since that was ensured earlier in pivot search:
1135* (a) d21 != 0 in 2x2 pivot case(4),
1136* since |d21| should be larger than |d11| and |d22|;
1137* (b) (D22*D11 - 1) != 0, since from (a),
1138* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
1139*
1140 d21 = w( k+1, k )
1141 d11 = w( k+1, k+1 ) / d21
1142 d22 = w( k, k ) / dconjg( d21 )
1143 t = one / ( dble( d11*d22 )-one )
1144*
1145* Update elements in columns A(k) and A(k+1) as
1146* dot products of rows of ( W(k) W(k+1) ) and columns
1147* of D**(-1)
1148*
1149 DO 80 j = k + 2, n
1150 a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /
1151 $ dconjg( d21 ) )
1152 a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /
1153 $ d21 )
1154 80 CONTINUE
1155 END IF
1156*
1157* Copy diagonal elements of D(K) to A,
1158* copy subdiagonal element of D(K) to E(K) and
1159* ZERO out subdiagonal entry of A
1160*
1161 a( k, k ) = w( k, k )
1162 a( k+1, k ) = czero
1163 a( k+1, k+1 ) = w( k+1, k+1 )
1164 e( k ) = w( k+1, k )
1165 e( k+1 ) = czero
1166*
1167* (2) Conjugate columns W(k) and W(k+1)
1168*
1169 CALL zlacgv( n-k, w( k+1, k ), 1 )
1170 CALL zlacgv( n-k-1, w( k+2, k+1 ), 1 )
1171*
1172 END IF
1173*
1174* End column K is nonsingular
1175*
1176 END IF
1177*
1178* Store details of the interchanges in IPIV
1179*
1180 IF( kstep.EQ.1 ) THEN
1181 ipiv( k ) = kp
1182 ELSE
1183 ipiv( k ) = -p
1184 ipiv( k+1 ) = -kp
1185 END IF
1186*
1187* Increase K and return to the start of the main loop
1188*
1189 k = k + kstep
1190 GO TO 70
1191*
1192 90 CONTINUE
1193*
1194* Update the lower triangle of A22 (= A(k:n,k:n)) as
1195*
1196* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
1197*
1198* computing blocks of NB columns at a time (note that conjg(W) is
1199* actually stored)
1200*
1201 DO 110 j = k, n, nb
1202 jb = min( nb, n-j+1 )
1203*
1204* Update the lower triangle of the diagonal block
1205*
1206 DO 100 jj = j, j + jb - 1
1207 a( jj, jj ) = dble( a( jj, jj ) )
1208 CALL zgemv( 'No transpose', j+jb-jj, k-1, -cone,
1209 $ a( jj, 1 ), lda, w( jj, 1 ), ldw, cone,
1210 $ a( jj, jj ), 1 )
1211 a( jj, jj ) = dble( a( jj, jj ) )
1212 100 CONTINUE
1213*
1214* Update the rectangular subdiagonal block
1215*
1216 IF( j+jb.LE.n )
1217 $ CALL zgemm( 'No transpose', 'Transpose', n-j-jb+1, jb,
1218 $ k-1, -cone, a( j+jb, 1 ), lda, w( j, 1 ),
1219 $ ldw, cone, a( j+jb, j ), lda )
1220 110 CONTINUE
1221*
1222* Set KB to the number of columns factorized
1223*
1224 kb = k - 1
1225*
1226 END IF
1227 RETURN
1228*
1229* End of ZLAHEF_RK
1230*

◆ zlahef_rook()

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

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

Purpose:
!>
!> ZLAHEF_ROOK computes a partial factorization of a complex Hermitian
!> 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**H U22**H )
!>
!> A  =  ( L11  0 ) (  D   0  ) ( L11**H L21**H )  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**H denotes the conjugate transpose of U.
!>
!> ZLAHEF_ROOK is an auxiliary routine called by ZHETRF_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
!>          Hermitian 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*16 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, 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*16 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 zlahef_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*16 A( LDA, * ), W( LDW, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 DOUBLE PRECISION ZERO, ONE
202 parameter( zero = 0.0d+0, one = 1.0d+0 )
203 COMPLEX*16 CONE
204 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
205 DOUBLE PRECISION EIGHT, SEVTEN
206 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
207* ..
208* .. Local Scalars ..
209 LOGICAL DONE
210 INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K,
211 $ KK, KKW, KP, KSTEP, KW, P
212 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, DTEMP, R1, ROWMAX, T,
213 $ SFMIN
214 COMPLEX*16 D11, D21, D22, Z
215* ..
216* .. External Functions ..
217 LOGICAL LSAME
218 INTEGER IZAMAX
219 DOUBLE PRECISION DLAMCH
220 EXTERNAL lsame, izamax, dlamch
221* ..
222* .. External Subroutines ..
223 EXTERNAL zcopy, zdscal, zgemm, zgemv, zlacgv, zswap
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC abs, dble, dconjg, dimag, max, min, sqrt
227* ..
228* .. Statement Functions ..
229 DOUBLE PRECISION CABS1
230* ..
231* .. Statement Function definitions ..
232 cabs1( z ) = abs( dble( z ) ) + abs( dimag( 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 = dlamch( '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 (note that conjg(W) is actually stored)
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 IF( k.GT.1 )
272 $ CALL zcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 )
273 w( k, kw ) = dble( a( k, k ) )
274 IF( k.LT.n ) THEN
275 CALL zgemv( 'No transpose', k, n-k, -cone, a( 1, k+1 ), lda,
276 $ w( k, kw+1 ), ldw, cone, w( 1, kw ), 1 )
277 w( k, kw ) = dble( w( k, kw ) )
278 END IF
279*
280* Determine rows and columns to be interchanged and whether
281* a 1-by-1 or 2-by-2 pivot block will be used
282*
283 absakk = abs( dble( w( k, kw ) ) )
284*
285* IMAX is the row-index of the largest off-diagonal element in
286* column K, and COLMAX is its absolute value.
287* Determine both COLMAX and IMAX.
288*
289 IF( k.GT.1 ) THEN
290 imax = izamax( k-1, w( 1, kw ), 1 )
291 colmax = cabs1( w( imax, kw ) )
292 ELSE
293 colmax = zero
294 END IF
295*
296 IF( max( absakk, colmax ).EQ.zero ) THEN
297*
298* Column K is zero or underflow: set INFO and continue
299*
300 IF( info.EQ.0 )
301 $ info = k
302 kp = k
303 a( k, k ) = dble( w( k, kw ) )
304 IF( k.GT.1 )
305 $ CALL zcopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 )
306 ELSE
307*
308* ============================================================
309*
310* BEGIN pivot search
311*
312* Case(1)
313* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
314* (used to handle NaN and Inf)
315 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
316*
317* no interchange, use 1-by-1 pivot block
318*
319 kp = k
320*
321 ELSE
322*
323* Lop until pivot found
324*
325 done = .false.
326*
327 12 CONTINUE
328*
329* BEGIN pivot search loop body
330*
331*
332* Copy column IMAX to column KW-1 of W and update it
333*
334 IF( imax.GT.1 )
335 $ CALL zcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),
336 $ 1 )
337 w( imax, kw-1 ) = dble( a( imax, imax ) )
338*
339 CALL zcopy( k-imax, a( imax, imax+1 ), lda,
340 $ w( imax+1, kw-1 ), 1 )
341 CALL zlacgv( k-imax, w( imax+1, kw-1 ), 1 )
342*
343 IF( k.LT.n ) THEN
344 CALL zgemv( 'No transpose', k, n-k, -cone,
345 $ a( 1, k+1 ), lda, w( imax, kw+1 ), ldw,
346 $ cone, w( 1, kw-1 ), 1 )
347 w( imax, kw-1 ) = dble( w( imax, kw-1 ) )
348 END IF
349*
350* JMAX is the column-index of the largest off-diagonal
351* element in row IMAX, and ROWMAX is its absolute value.
352* Determine both ROWMAX and JMAX.
353*
354 IF( imax.NE.k ) THEN
355 jmax = imax + izamax( k-imax, w( imax+1, kw-1 ),
356 $ 1 )
357 rowmax = cabs1( w( jmax, kw-1 ) )
358 ELSE
359 rowmax = zero
360 END IF
361*
362 IF( imax.GT.1 ) THEN
363 itemp = izamax( imax-1, w( 1, kw-1 ), 1 )
364 dtemp = cabs1( w( itemp, kw-1 ) )
365 IF( dtemp.GT.rowmax ) THEN
366 rowmax = dtemp
367 jmax = itemp
368 END IF
369 END IF
370*
371* Case(2)
372* Equivalent to testing for
373* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
374* (used to handle NaN and Inf)
375*
376 IF( .NOT.( abs( dble( w( imax,kw-1 ) ) )
377 $ .LT.alpha*rowmax ) ) THEN
378*
379* interchange rows and columns K and IMAX,
380* use 1-by-1 pivot block
381*
382 kp = imax
383*
384* copy column KW-1 of W to column KW of W
385*
386 CALL zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
387*
388 done = .true.
389*
390* Case(3)
391* Equivalent to testing for ROWMAX.EQ.COLMAX,
392* (used to handle NaN and Inf)
393*
394 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
395 $ THEN
396*
397* interchange rows and columns K-1 and IMAX,
398* use 2-by-2 pivot block
399*
400 kp = imax
401 kstep = 2
402 done = .true.
403*
404* Case(4)
405 ELSE
406*
407* Pivot not found: set params and repeat
408*
409 p = imax
410 colmax = rowmax
411 imax = jmax
412*
413* Copy updated JMAXth (next IMAXth) column to Kth of W
414*
415 CALL zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 )
416*
417 END IF
418*
419*
420* END pivot search loop body
421*
422 IF( .NOT.done ) GOTO 12
423*
424 END IF
425*
426* END pivot search
427*
428* ============================================================
429*
430* KK is the column of A where pivoting step stopped
431*
432 kk = k - kstep + 1
433*
434* KKW is the column of W which corresponds to column KK of A
435*
436 kkw = nb + kk - n
437*
438* Interchange rows and columns P and K.
439* Updated column P is already stored in column KW of W.
440*
441 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
442*
443* Copy non-updated column K to column P of submatrix A
444* at step K. No need to copy element into columns
445* K and K-1 of A for 2-by-2 pivot, since these columns
446* will be later overwritten.
447*
448 a( p, p ) = dble( a( k, k ) )
449 CALL zcopy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),
450 $ lda )
451 CALL zlacgv( k-1-p, a( p, p+1 ), lda )
452 IF( p.GT.1 )
453 $ CALL zcopy( p-1, a( 1, k ), 1, a( 1, p ), 1 )
454*
455* Interchange rows K and P in the last K+1 to N columns of A
456* (columns K and K-1 of A for 2-by-2 pivot will be
457* later overwritten). Interchange rows K and P
458* in last KKW to NB columns of W.
459*
460 IF( k.LT.n )
461 $ CALL zswap( n-k, a( k, k+1 ), lda, a( p, k+1 ),
462 $ lda )
463 CALL zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ),
464 $ ldw )
465 END IF
466*
467* Interchange rows and columns KP and KK.
468* Updated column KP is already stored in column KKW of W.
469*
470 IF( kp.NE.kk ) THEN
471*
472* Copy non-updated column KK to column KP of submatrix A
473* at step K. No need to copy element into column K
474* (or K and K-1 for 2-by-2 pivot) of A, since these columns
475* will be later overwritten.
476*
477 a( kp, kp ) = dble( a( kk, kk ) )
478 CALL zcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
479 $ lda )
480 CALL zlacgv( kk-1-kp, a( kp, kp+1 ), lda )
481 IF( kp.GT.1 )
482 $ CALL zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
483*
484* Interchange rows KK and KP in last K+1 to N columns of A
485* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
486* later overwritten). Interchange rows KK and KP
487* in last KKW to NB columns of W.
488*
489 IF( k.LT.n )
490 $ CALL zswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
491 $ lda )
492 CALL zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),
493 $ ldw )
494 END IF
495*
496 IF( kstep.EQ.1 ) THEN
497*
498* 1-by-1 pivot block D(k): column kw of W now holds
499*
500* W(kw) = U(k)*D(k),
501*
502* where U(k) is the k-th column of U
503*
504* (1) Store subdiag. elements of column U(k)
505* and 1-by-1 block D(k) in column k of A.
506* (NOTE: Diagonal element U(k,k) is a UNIT element
507* and not stored)
508* A(k,k) := D(k,k) = W(k,kw)
509* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
510*
511* (NOTE: No need to use for Hermitian matrix
512* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
513* element D(k,k) from W (potentially saves only one load))
514 CALL zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
515 IF( k.GT.1 ) THEN
516*
517* (NOTE: No need to check if A(k,k) is NOT ZERO,
518* since that was ensured earlier in pivot search:
519* case A(k,k) = 0 falls into 2x2 pivot case(3))
520*
521* Handle division by a small number
522*
523 t = dble( a( k, k ) )
524 IF( abs( t ).GE.sfmin ) THEN
525 r1 = one / t
526 CALL zdscal( k-1, r1, a( 1, k ), 1 )
527 ELSE
528 DO 14 ii = 1, k-1
529 a( ii, k ) = a( ii, k ) / t
530 14 CONTINUE
531 END IF
532*
533* (2) Conjugate column W(kw)
534*
535 CALL zlacgv( k-1, w( 1, kw ), 1 )
536 END IF
537*
538 ELSE
539*
540* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
541*
542* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
543*
544* where U(k) and U(k-1) are the k-th and (k-1)-th columns
545* of U
546*
547* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
548* block D(k-1:k,k-1:k) in columns k-1 and k of A.
549* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
550* block and not stored)
551* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
552* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
553* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
554*
555 IF( k.GT.2 ) THEN
556*
557* Factor out the columns of the inverse of 2-by-2 pivot
558* block D, so that each column contains 1, to reduce the
559* number of FLOPS when we multiply panel
560* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
561*
562* D**(-1) = ( d11 cj(d21) )**(-1) =
563* ( d21 d22 )
564*
565* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
566* ( (-d21) ( d11 ) )
567*
568* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
569*
570* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
571* ( ( -1 ) ( d11/conj(d21) ) )
572*
573* = 1/(|d21|**2) * 1/(D22*D11-1) *
574*
575* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
576* ( ( -1 ) ( D22 ) )
577*
578* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
579* ( ( -1 ) ( D22 ) )
580*
581* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
582* ( ( -1 ) ( D22 ) )
583*
584* Handle division by a small number. (NOTE: order of
585* operations is important)
586*
587* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
588* ( (( -1 ) ) (( D22 ) ) ),
589*
590* where D11 = d22/d21,
591* D22 = d11/conj(d21),
592* D21 = d21,
593* T = 1/(D22*D11-1).
594*
595* (NOTE: No need to check for division by ZERO,
596* since that was ensured earlier in pivot search:
597* (a) d21 != 0 in 2x2 pivot case(4),
598* since |d21| should be larger than |d11| and |d22|;
599* (b) (D22*D11 - 1) != 0, since from (a),
600* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
601*
602 d21 = w( k-1, kw )
603 d11 = w( k, kw ) / dconjg( d21 )
604 d22 = w( k-1, kw-1 ) / d21
605 t = one / ( dble( d11*d22 )-one )
606*
607* Update elements in columns A(k-1) and A(k) as
608* dot products of rows of ( W(kw-1) W(kw) ) and columns
609* of D**(-1)
610*
611 DO 20 j = 1, k - 2
612 a( j, k-1 ) = t*( ( d11*w( j, kw-1 )-w( j, kw ) ) /
613 $ d21 )
614 a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /
615 $ dconjg( d21 ) )
616 20 CONTINUE
617 END IF
618*
619* Copy D(k) to A
620*
621 a( k-1, k-1 ) = w( k-1, kw-1 )
622 a( k-1, k ) = w( k-1, kw )
623 a( k, k ) = w( k, kw )
624*
625* (2) Conjugate columns W(kw) and W(kw-1)
626*
627 CALL zlacgv( k-1, w( 1, kw ), 1 )
628 CALL zlacgv( k-2, w( 1, kw-1 ), 1 )
629*
630 END IF
631*
632 END IF
633*
634* Store details of the interchanges in IPIV
635*
636 IF( kstep.EQ.1 ) THEN
637 ipiv( k ) = kp
638 ELSE
639 ipiv( k ) = -p
640 ipiv( k-1 ) = -kp
641 END IF
642*
643* Decrease K and return to the start of the main loop
644*
645 k = k - kstep
646 GO TO 10
647*
648 30 CONTINUE
649*
650* Update the upper triangle of A11 (= A(1:k,1:k)) as
651*
652* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
653*
654* computing blocks of NB columns at a time (note that conjg(W) is
655* actually stored)
656*
657 DO 50 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
658 jb = min( nb, k-j+1 )
659*
660* Update the upper triangle of the diagonal block
661*
662 DO 40 jj = j, j + jb - 1
663 a( jj, jj ) = dble( a( jj, jj ) )
664 CALL zgemv( 'No transpose', jj-j+1, n-k, -cone,
665 $ a( j, k+1 ), lda, w( jj, kw+1 ), ldw, cone,
666 $ a( j, jj ), 1 )
667 a( jj, jj ) = dble( a( jj, jj ) )
668 40 CONTINUE
669*
670* Update the rectangular superdiagonal block
671*
672 IF( j.GE.2 )
673 $ CALL zgemm( 'No transpose', 'Transpose', j-1, jb, n-k,
674 $ -cone, a( 1, k+1 ), lda, w( j, kw+1 ), ldw,
675 $ cone, a( 1, j ), lda )
676 50 CONTINUE
677*
678* Put U12 in standard form by partially undoing the interchanges
679* in of rows in columns k+1:n looping backwards from k+1 to n
680*
681 j = k + 1
682 60 CONTINUE
683*
684* Undo the interchanges (if any) of rows J and JP2
685* (or J and JP2, and J+1 and JP1) at each step J
686*
687 kstep = 1
688 jp1 = 1
689* (Here, J is a diagonal index)
690 jj = j
691 jp2 = ipiv( j )
692 IF( jp2.LT.0 ) THEN
693 jp2 = -jp2
694* (Here, J is a diagonal index)
695 j = j + 1
696 jp1 = -ipiv( j )
697 kstep = 2
698 END IF
699* (NOTE: Here, J is used to determine row length. Length N-J+1
700* of the rows to swap back doesn't include diagonal element)
701 j = j + 1
702 IF( jp2.NE.jj .AND. j.LE.n )
703 $ CALL zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), lda )
704 jj = jj + 1
705 IF( kstep.EQ.2 .AND. jp1.NE.jj .AND. j.LE.n )
706 $ CALL zswap( n-j+1, a( jp1, j ), lda, a( jj, j ), lda )
707 IF( j.LT.n )
708 $ GO TO 60
709*
710* Set KB to the number of columns factorized
711*
712 kb = n - k
713*
714 ELSE
715*
716* Factorize the leading columns of A using the lower triangle
717* of A and working forwards, and compute the matrix W = L21*D
718* for use in updating A22 (note that conjg(W) is actually stored)
719*
720* K is the main loop index, increasing from 1 in steps of 1 or 2
721*
722 k = 1
723 70 CONTINUE
724*
725* Exit from loop
726*
727 IF( ( k.GE.nb .AND. nb.LT.n ) .OR. k.GT.n )
728 $ GO TO 90
729*
730 kstep = 1
731 p = k
732*
733* Copy column K of A to column K of W and update column K of W
734*
735 w( k, k ) = dble( a( k, k ) )
736 IF( k.LT.n )
737 $ CALL zcopy( n-k, a( k+1, k ), 1, w( k+1, k ), 1 )
738 IF( k.GT.1 ) THEN
739 CALL zgemv( 'No transpose', n-k+1, k-1, -cone, a( k, 1 ),
740 $ lda, w( k, 1 ), ldw, cone, w( k, k ), 1 )
741 w( k, k ) = dble( w( k, k ) )
742 END IF
743*
744* Determine rows and columns to be interchanged and whether
745* a 1-by-1 or 2-by-2 pivot block will be used
746*
747 absakk = abs( dble( w( k, k ) ) )
748*
749* IMAX is the row-index of the largest off-diagonal element in
750* column K, and COLMAX is its absolute value.
751* Determine both COLMAX and IMAX.
752*
753 IF( k.LT.n ) THEN
754 imax = k + izamax( n-k, w( k+1, k ), 1 )
755 colmax = cabs1( w( imax, k ) )
756 ELSE
757 colmax = zero
758 END IF
759*
760 IF( max( absakk, colmax ).EQ.zero ) THEN
761*
762* Column K is zero or underflow: set INFO and continue
763*
764 IF( info.EQ.0 )
765 $ info = k
766 kp = k
767 a( k, k ) = dble( w( k, k ) )
768 IF( k.LT.n )
769 $ CALL zcopy( n-k, w( k+1, k ), 1, a( k+1, k ), 1 )
770 ELSE
771*
772* ============================================================
773*
774* BEGIN pivot search
775*
776* Case(1)
777* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
778* (used to handle NaN and Inf)
779*
780 IF( .NOT.( absakk.LT.alpha*colmax ) ) THEN
781*
782* no interchange, use 1-by-1 pivot block
783*
784 kp = k
785*
786 ELSE
787*
788 done = .false.
789*
790* Loop until pivot found
791*
792 72 CONTINUE
793*
794* BEGIN pivot search loop body
795*
796*
797* Copy column IMAX to column k+1 of W and update it
798*
799 CALL zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1)
800 CALL zlacgv( imax-k, w( k, k+1 ), 1 )
801 w( imax, k+1 ) = dble( a( imax, imax ) )
802*
803 IF( imax.LT.n )
804 $ CALL zcopy( n-imax, a( imax+1, imax ), 1,
805 $ w( imax+1, k+1 ), 1 )
806*
807 IF( k.GT.1 ) THEN
808 CALL zgemv( 'No transpose', n-k+1, k-1, -cone,
809 $ a( k, 1 ), lda, w( imax, 1 ), ldw,
810 $ cone, w( k, k+1 ), 1 )
811 w( imax, k+1 ) = dble( w( imax, k+1 ) )
812 END IF
813*
814* JMAX is the column-index of the largest off-diagonal
815* element in row IMAX, and ROWMAX is its absolute value.
816* Determine both ROWMAX and JMAX.
817*
818 IF( imax.NE.k ) THEN
819 jmax = k - 1 + izamax( imax-k, w( k, k+1 ), 1 )
820 rowmax = cabs1( w( jmax, k+1 ) )
821 ELSE
822 rowmax = zero
823 END IF
824*
825 IF( imax.LT.n ) THEN
826 itemp = imax + izamax( n-imax, w( imax+1, k+1 ), 1)
827 dtemp = cabs1( w( itemp, k+1 ) )
828 IF( dtemp.GT.rowmax ) THEN
829 rowmax = dtemp
830 jmax = itemp
831 END IF
832 END IF
833*
834* Case(2)
835* Equivalent to testing for
836* ABS( DBLE( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX
837* (used to handle NaN and Inf)
838*
839 IF( .NOT.( abs( dble( w( imax,k+1 ) ) )
840 $ .LT.alpha*rowmax ) ) THEN
841*
842* interchange rows and columns K and IMAX,
843* use 1-by-1 pivot block
844*
845 kp = imax
846*
847* copy column K+1 of W to column K of W
848*
849 CALL zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
850*
851 done = .true.
852*
853* Case(3)
854* Equivalent to testing for ROWMAX.EQ.COLMAX,
855* (used to handle NaN and Inf)
856*
857 ELSE IF( ( p.EQ.jmax ) .OR. ( rowmax.LE.colmax ) )
858 $ THEN
859*
860* interchange rows and columns K+1 and IMAX,
861* use 2-by-2 pivot block
862*
863 kp = imax
864 kstep = 2
865 done = .true.
866*
867* Case(4)
868 ELSE
869*
870* Pivot not found: set params and repeat
871*
872 p = imax
873 colmax = rowmax
874 imax = jmax
875*
876* Copy updated JMAXth (next IMAXth) column to Kth of W
877*
878 CALL zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 )
879*
880 END IF
881*
882*
883* End pivot search loop body
884*
885 IF( .NOT.done ) GOTO 72
886*
887 END IF
888*
889* END pivot search
890*
891* ============================================================
892*
893* KK is the column of A where pivoting step stopped
894*
895 kk = k + kstep - 1
896*
897* Interchange rows and columns P and K (only for 2-by-2 pivot).
898* Updated column P is already stored in column K of W.
899*
900 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) ) THEN
901*
902* Copy non-updated column KK-1 to column P of submatrix A
903* at step K. No need to copy element into columns
904* K and K+1 of A for 2-by-2 pivot, since these columns
905* will be later overwritten.
906*
907 a( p, p ) = dble( a( k, k ) )
908 CALL zcopy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda )
909 CALL zlacgv( p-k-1, a( p, k+1 ), lda )
910 IF( p.LT.n )
911 $ CALL zcopy( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
912*
913* Interchange rows K and P in first K-1 columns of A
914* (columns K and K+1 of A for 2-by-2 pivot will be
915* later overwritten). Interchange rows K and P
916* in first KK columns of W.
917*
918 IF( k.GT.1 )
919 $ CALL zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda )
920 CALL zswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw )
921 END IF
922*
923* Interchange rows and columns KP and KK.
924* Updated column KP is already stored in column KK of W.
925*
926 IF( kp.NE.kk ) THEN
927*
928* Copy non-updated column KK to column KP of submatrix A
929* at step K. No need to copy element into column K
930* (or K and K+1 for 2-by-2 pivot) of A, since these columns
931* will be later overwritten.
932*
933 a( kp, kp ) = dble( a( kk, kk ) )
934 CALL zcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
935 $ lda )
936 CALL zlacgv( kp-kk-1, a( kp, kk+1 ), lda )
937 IF( kp.LT.n )
938 $ CALL zcopy( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
939*
940* Interchange rows KK and KP in first K-1 columns of A
941* (column K (or K and K+1 for 2-by-2 pivot) of A will be
942* later overwritten). Interchange rows KK and KP
943* in first KK columns of W.
944*
945 IF( k.GT.1 )
946 $ CALL zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
947 CALL zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw )
948 END IF
949*
950 IF( kstep.EQ.1 ) THEN
951*
952* 1-by-1 pivot block D(k): column k of W now holds
953*
954* W(k) = L(k)*D(k),
955*
956* where L(k) is the k-th column of L
957*
958* (1) Store subdiag. elements of column L(k)
959* and 1-by-1 block D(k) in column k of A.
960* (NOTE: Diagonal element L(k,k) is a UNIT element
961* and not stored)
962* A(k,k) := D(k,k) = W(k,k)
963* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
964*
965* (NOTE: No need to use for Hermitian matrix
966* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
967* element D(k,k) from W (potentially saves only one load))
968 CALL zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 )
969 IF( k.LT.n ) THEN
970*
971* (NOTE: No need to check if A(k,k) is NOT ZERO,
972* since that was ensured earlier in pivot search:
973* case A(k,k) = 0 falls into 2x2 pivot case(3))
974*
975* Handle division by a small number
976*
977 t = dble( a( k, k ) )
978 IF( abs( t ).GE.sfmin ) THEN
979 r1 = one / t
980 CALL zdscal( n-k, r1, a( k+1, k ), 1 )
981 ELSE
982 DO 74 ii = k + 1, n
983 a( ii, k ) = a( ii, k ) / t
984 74 CONTINUE
985 END IF
986*
987* (2) Conjugate column W(k)
988*
989 CALL zlacgv( n-k, w( k+1, k ), 1 )
990 END IF
991*
992 ELSE
993*
994* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
995*
996* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
997*
998* where L(k) and L(k+1) are the k-th and (k+1)-th columns
999* of L
1000*
1001* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
1002* block D(k:k+1,k:k+1) in columns k and k+1 of A.
1003* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
1004* block and not stored.
1005* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
1006* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
1007* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
1008*
1009 IF( k.LT.n-1 ) THEN
1010*
1011* Factor out the columns of the inverse of 2-by-2 pivot
1012* block D, so that each column contains 1, to reduce the
1013* number of FLOPS when we multiply panel
1014* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
1015*
1016* D**(-1) = ( d11 cj(d21) )**(-1) =
1017* ( d21 d22 )
1018*
1019* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
1020* ( (-d21) ( d11 ) )
1021*
1022* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
1023*
1024* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
1025* ( ( -1 ) ( d11/conj(d21) ) )
1026*
1027* = 1/(|d21|**2) * 1/(D22*D11-1) *
1028*
1029* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
1030* ( ( -1 ) ( D22 ) )
1031*
1032* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
1033* ( ( -1 ) ( D22 ) )
1034*
1035* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
1036* ( ( -1 ) ( D22 ) )
1037*
1038* Handle division by a small number. (NOTE: order of
1039* operations is important)
1040*
1041* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
1042* ( (( -1 ) ) (( D22 ) ) ),
1043*
1044* where D11 = d22/d21,
1045* D22 = d11/conj(d21),
1046* D21 = d21,
1047* T = 1/(D22*D11-1).
1048*
1049* (NOTE: No need to check for division by ZERO,
1050* since that was ensured earlier in pivot search:
1051* (a) d21 != 0 in 2x2 pivot case(4),
1052* since |d21| should be larger than |d11| and |d22|;
1053* (b) (D22*D11 - 1) != 0, since from (a),
1054* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
1055*
1056 d21 = w( k+1, k )
1057 d11 = w( k+1, k+1 ) / d21
1058 d22 = w( k, k ) / dconjg( d21 )
1059 t = one / ( dble( d11*d22 )-one )
1060*
1061* Update elements in columns A(k) and A(k+1) as
1062* dot products of rows of ( W(k) W(k+1) ) and columns
1063* of D**(-1)
1064*
1065 DO 80 j = k + 2, n
1066 a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /
1067 $ dconjg( d21 ) )
1068 a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /
1069 $ d21 )
1070 80 CONTINUE
1071 END IF
1072*
1073* Copy D(k) to A
1074*
1075 a( k, k ) = w( k, k )
1076 a( k+1, k ) = w( k+1, k )
1077 a( k+1, k+1 ) = w( k+1, k+1 )
1078*
1079* (2) Conjugate columns W(k) and W(k+1)
1080*
1081 CALL zlacgv( n-k, w( k+1, k ), 1 )
1082 CALL zlacgv( n-k-1, w( k+2, k+1 ), 1 )
1083*
1084 END IF
1085*
1086 END IF
1087*
1088* Store details of the interchanges in IPIV
1089*
1090 IF( kstep.EQ.1 ) THEN
1091 ipiv( k ) = kp
1092 ELSE
1093 ipiv( k ) = -p
1094 ipiv( k+1 ) = -kp
1095 END IF
1096*
1097* Increase K and return to the start of the main loop
1098*
1099 k = k + kstep
1100 GO TO 70
1101*
1102 90 CONTINUE
1103*
1104* Update the lower triangle of A22 (= A(k:n,k:n)) as
1105*
1106* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
1107*
1108* computing blocks of NB columns at a time (note that conjg(W) is
1109* actually stored)
1110*
1111 DO 110 j = k, n, nb
1112 jb = min( nb, n-j+1 )
1113*
1114* Update the lower triangle of the diagonal block
1115*
1116 DO 100 jj = j, j + jb - 1
1117 a( jj, jj ) = dble( a( jj, jj ) )
1118 CALL zgemv( 'No transpose', j+jb-jj, k-1, -cone,
1119 $ a( jj, 1 ), lda, w( jj, 1 ), ldw, cone,
1120 $ a( jj, jj ), 1 )
1121 a( jj, jj ) = dble( a( jj, jj ) )
1122 100 CONTINUE
1123*
1124* Update the rectangular subdiagonal block
1125*
1126 IF( j+jb.LE.n )
1127 $ CALL zgemm( 'No transpose', 'Transpose', n-j-jb+1, jb,
1128 $ k-1, -cone, a( j+jb, 1 ), lda, w( j, 1 ),
1129 $ ldw, cone, a( j+jb, j ), lda )
1130 110 CONTINUE
1131*
1132* Put L21 in standard form by partially undoing the interchanges
1133* of rows in columns 1:k-1 looping backwards from k-1 to 1
1134*
1135 j = k - 1
1136 120 CONTINUE
1137*
1138* Undo the interchanges (if any) of rows J and JP2
1139* (or J and JP2, and J-1 and JP1) at each step J
1140*
1141 kstep = 1
1142 jp1 = 1
1143* (Here, J is a diagonal index)
1144 jj = j
1145 jp2 = ipiv( j )
1146 IF( jp2.LT.0 ) THEN
1147 jp2 = -jp2
1148* (Here, J is a diagonal index)
1149 j = j - 1
1150 jp1 = -ipiv( j )
1151 kstep = 2
1152 END IF
1153* (NOTE: Here, J is used to determine row length. Length J
1154* of the rows to swap back doesn't include diagonal element)
1155 j = j - 1
1156 IF( jp2.NE.jj .AND. j.GE.1 )
1157 $ CALL zswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda )
1158 jj = jj -1
1159 IF( kstep.EQ.2 .AND. jp1.NE.jj .AND. j.GE.1 )
1160 $ CALL zswap( j, a( jp1, 1 ), lda, a( jj, 1 ), lda )
1161 IF( j.GT.1 )
1162 $ GO TO 120
1163*
1164* Set KB to the number of columns factorized
1165*
1166 kb = k - 1
1167*
1168 END IF
1169 RETURN
1170*
1171* End of ZLAHEF_ROOK
1172*