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

Functions

subroutine dla_syamv (uplo, n, alpha, a, lda, x, incx, beta, y, incy)
 DLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds.
double precision function dla_syrcond (uplo, n, a, lda, af, ldaf, ipiv, cmode, c, info, work, iwork)
 DLA_SYRCOND estimates the Skeel condition number for a symmetric indefinite matrix.
subroutine dla_syrfsx_extended (prec_type, uplo, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
 DLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric indefinite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.
double precision function dla_syrpvgrw (uplo, n, info, a, lda, af, ldaf, ipiv, work)
 DLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite matrix.
subroutine dlasyf (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
subroutine dlasyf_aa (uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
 DLASYF_AA
subroutine dlasyf_rk (uplo, n, nb, kb, a, lda, e, ipiv, w, ldw, info)
 DLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
subroutine dlasyf_rook (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 DLASYF_ROOK *> DLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
subroutine dsycon (uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
 DSYCON
subroutine dsycon_3 (uplo, n, a, lda, e, ipiv, anorm, rcond, work, iwork, info)
 DSYCON_3
subroutine dsycon_rook (uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
  DSYCON_ROOK
subroutine dsyconv (uplo, way, n, a, lda, ipiv, e, info)
 DSYCONV
subroutine dsyconvf (uplo, way, n, a, lda, e, ipiv, info)
 DSYCONVF
subroutine dsyconvf_rook (uplo, way, n, a, lda, e, ipiv, info)
 DSYCONVF_ROOK
subroutine dsyequb (uplo, n, a, lda, s, scond, amax, work, info)
 DSYEQUB
subroutine dsygs2 (itype, uplo, n, a, lda, b, ldb, info)
 DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm).
subroutine dsygst (itype, uplo, n, a, lda, b, ldb, info)
 DSYGST
subroutine dsyrfs (uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DSYRFS
subroutine dsyrfsx (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, iwork, info)
 DSYRFSX
subroutine dsytd2 (uplo, n, a, lda, d, e, tau, info)
 DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm).
subroutine dsytf2 (uplo, n, a, lda, ipiv, info)
 DSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).
subroutine dsytf2_rk (uplo, n, a, lda, e, ipiv, info)
 DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
subroutine dsytf2_rook (uplo, n, a, lda, ipiv, info)
 DSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
subroutine dsytrd (uplo, n, a, lda, d, e, tau, work, lwork, info)
 DSYTRD
subroutine dsytrd_2stage (vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
 DSYTRD_2STAGE
subroutine dsytrd_sy2sb (uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
 DSYTRD_SY2SB
subroutine dsytrf (uplo, n, a, lda, ipiv, work, lwork, info)
 DSYTRF
subroutine dsytrf_aa (uplo, n, a, lda, ipiv, work, lwork, info)
 DSYTRF_AA
subroutine dsytrf_aa_2stage (uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
 DSYTRF_AA_2STAGE
subroutine dsytrf_rk (uplo, n, a, lda, e, ipiv, work, lwork, info)
 DSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
subroutine dsytrf_rook (uplo, n, a, lda, ipiv, work, lwork, info)
 DSYTRF_ROOK
subroutine dsytri (uplo, n, a, lda, ipiv, work, info)
 DSYTRI
subroutine dsytri2 (uplo, n, a, lda, ipiv, work, lwork, info)
 DSYTRI2
subroutine dsytri2x (uplo, n, a, lda, ipiv, work, nb, info)
 DSYTRI2X
subroutine dsytri_3 (uplo, n, a, lda, e, ipiv, work, lwork, info)
 DSYTRI_3
subroutine dsytri_3x (uplo, n, a, lda, e, ipiv, work, nb, info)
 DSYTRI_3X
subroutine dsytri_rook (uplo, n, a, lda, ipiv, work, info)
 DSYTRI_ROOK
subroutine dsytrs (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 DSYTRS
subroutine dsytrs2 (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
 DSYTRS2
subroutine dsytrs_3 (uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
 DSYTRS_3
subroutine dsytrs_aa (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
 DSYTRS_AA
subroutine dsytrs_aa_2stage (uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
 DSYTRS_AA_2STAGE
subroutine dsytrs_rook (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 DSYTRS_ROOK
subroutine dtgsyl (trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
 DTGSYL
subroutine dtrsyl (trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
 DTRSYL

Detailed Description

This is the group of double computational functions for SY matrices

Function Documentation

◆ dla_syamv()

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

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

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

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

◆ dla_syrcond()

double precision function dla_syrcond ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
integer cmode,
double precision, dimension( * ) c,
integer info,
double precision, dimension( * ) work,
integer, dimension( * ) iwork )

DLA_SYRCOND estimates the Skeel condition number for a symmetric indefinite matrix.

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

Purpose:
!>
!>    DLA_SYRCOND estimates the Skeel condition number of  op(A) * op2(C)
!>    where op2 is determined by CMODE as follows
!>    CMODE =  1    op2(C) = C
!>    CMODE =  0    op2(C) = I
!>    CMODE = -1    op2(C) = inv(C)
!>    The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!>    is computed by computing scaling factors R such that
!>    diag(R)*A*op2(C) is row equilibrated and computing the standard
!>    infinity-norm condition number.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by DSYTRF.
!>
[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 DSYTRF.
!>
[in]CMODE
!>          CMODE is INTEGER
!>     Determines op2(C) in the formula op(A) * op2(C) as follows:
!>     CMODE =  1    op2(C) = C
!>     CMODE =  0    op2(C) = I
!>     CMODE = -1    op2(C) = inv(C)
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The vector C in the formula op(A) * op2(C).
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (3*N).
!>     Workspace.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file dla_syrcond.f.

148*
149* -- LAPACK computational routine --
150* -- LAPACK is a software package provided by Univ. of Tennessee, --
151* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
152*
153* .. Scalar Arguments ..
154 CHARACTER UPLO
155 INTEGER N, LDA, LDAF, INFO, CMODE
156* ..
157* .. Array Arguments
158 INTEGER IWORK( * ), IPIV( * )
159 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * )
160* ..
161*
162* =====================================================================
163*
164* .. Local Scalars ..
165 CHARACTER NORMIN
166 INTEGER KASE, I, J
167 DOUBLE PRECISION AINVNM, SMLNUM, TMP
168 LOGICAL UP
169* ..
170* .. Local Arrays ..
171 INTEGER ISAVE( 3 )
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 DOUBLE PRECISION DLAMCH
176 EXTERNAL lsame, dlamch
177* ..
178* .. External Subroutines ..
179 EXTERNAL dlacn2, xerbla, dsytrs
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC abs, max
183* ..
184* .. Executable Statements ..
185*
186 dla_syrcond = 0.0d+0
187*
188 info = 0
189 IF( n.LT.0 ) THEN
190 info = -2
191 ELSE IF( lda.LT.max( 1, n ) ) THEN
192 info = -4
193 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
194 info = -6
195 END IF
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'DLA_SYRCOND', -info )
198 RETURN
199 END IF
200 IF( n.EQ.0 ) THEN
201 dla_syrcond = 1.0d+0
202 RETURN
203 END IF
204 up = .false.
205 IF ( lsame( uplo, 'U' ) ) up = .true.
206*
207* Compute the equilibration matrix R such that
208* inv(R)*A*C has unit 1-norm.
209*
210 IF ( up ) THEN
211 DO i = 1, n
212 tmp = 0.0d+0
213 IF ( cmode .EQ. 1 ) THEN
214 DO j = 1, i
215 tmp = tmp + abs( a( j, i ) * c( j ) )
216 END DO
217 DO j = i+1, n
218 tmp = tmp + abs( a( i, j ) * c( j ) )
219 END DO
220 ELSE IF ( cmode .EQ. 0 ) THEN
221 DO j = 1, i
222 tmp = tmp + abs( a( j, i ) )
223 END DO
224 DO j = i+1, n
225 tmp = tmp + abs( a( i, j ) )
226 END DO
227 ELSE
228 DO j = 1, i
229 tmp = tmp + abs( a( j, i ) / c( j ) )
230 END DO
231 DO j = i+1, n
232 tmp = tmp + abs( a( i, j ) / c( j ) )
233 END DO
234 END IF
235 work( 2*n+i ) = tmp
236 END DO
237 ELSE
238 DO i = 1, n
239 tmp = 0.0d+0
240 IF ( cmode .EQ. 1 ) THEN
241 DO j = 1, i
242 tmp = tmp + abs( a( i, j ) * c( j ) )
243 END DO
244 DO j = i+1, n
245 tmp = tmp + abs( a( j, i ) * c( j ) )
246 END DO
247 ELSE IF ( cmode .EQ. 0 ) THEN
248 DO j = 1, i
249 tmp = tmp + abs( a( i, j ) )
250 END DO
251 DO j = i+1, n
252 tmp = tmp + abs( a( j, i ) )
253 END DO
254 ELSE
255 DO j = 1, i
256 tmp = tmp + abs( a( i, j) / c( j ) )
257 END DO
258 DO j = i+1, n
259 tmp = tmp + abs( a( j, i) / c( j ) )
260 END DO
261 END IF
262 work( 2*n+i ) = tmp
263 END DO
264 ENDIF
265*
266* Estimate the norm of inv(op(A)).
267*
268 smlnum = dlamch( 'Safe minimum' )
269 ainvnm = 0.0d+0
270 normin = 'N'
271
272 kase = 0
273 10 CONTINUE
274 CALL dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
275 IF( kase.NE.0 ) THEN
276 IF( kase.EQ.2 ) THEN
277*
278* Multiply by R.
279*
280 DO i = 1, n
281 work( i ) = work( i ) * work( 2*n+i )
282 END DO
283
284 IF ( up ) THEN
285 CALL dsytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info )
286 ELSE
287 CALL dsytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info )
288 ENDIF
289*
290* Multiply by inv(C).
291*
292 IF ( cmode .EQ. 1 ) THEN
293 DO i = 1, n
294 work( i ) = work( i ) / c( i )
295 END DO
296 ELSE IF ( cmode .EQ. -1 ) THEN
297 DO i = 1, n
298 work( i ) = work( i ) * c( i )
299 END DO
300 END IF
301 ELSE
302*
303* Multiply by inv(C**T).
304*
305 IF ( cmode .EQ. 1 ) THEN
306 DO i = 1, n
307 work( i ) = work( i ) / c( i )
308 END DO
309 ELSE IF ( cmode .EQ. -1 ) THEN
310 DO i = 1, n
311 work( i ) = work( i ) * c( i )
312 END DO
313 END IF
314
315 IF ( up ) THEN
316 CALL dsytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info )
317 ELSE
318 CALL dsytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info )
319 ENDIF
320*
321* Multiply by R.
322*
323 DO i = 1, n
324 work( i ) = work( i ) * work( 2*n+i )
325 END DO
326 END IF
327*
328 GO TO 10
329 END IF
330*
331* Compute the estimate of the reciprocal condition number.
332*
333 IF( ainvnm .NE. 0.0d+0 )
334 $ dla_syrcond = ( 1.0d+0 / ainvnm )
335*
336 RETURN
337*
338* End of DLA_SYRCOND
339*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
dlacn2
subroutine dlacn2(n, v, x, isgn, est, kase, isave)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition dlacn2.f:136
dla_syrcond
double precision function dla_syrcond(uplo, n, a, lda, af, ldaf, ipiv, cmode, c, info, work, iwork)
DLA_SYRCOND estimates the Skeel condition number for a symmetric indefinite matrix.
Definition dla_syrcond.f:148
dsytrs
subroutine dsytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
DSYTRS
Definition dsytrs.f:120

◆ dla_syrfsx_extended()

subroutine dla_syrfsx_extended ( integer prec_type,
character uplo,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
logical colequ,
double precision, dimension( * ) c,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, 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,
double precision, dimension( * ) res,
double precision, dimension( * ) ayb,
double precision, dimension( * ) dy,
double precision, dimension( * ) y_tail,
double precision rcond,
integer ithresh,
double precision rthresh,
double precision dz_ub,
logical ignore_cwise,
integer info )

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

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

Purpose:
!>
!>
!> DLA_SYRFSX_EXTENDED improves the computed solution to a system of
!> linear equations by performing extra-precise iterative refinement
!> and provides error bounds and backward error estimates for the solution.
!> This subroutine is called by DSYRFSX 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by DSYTRF.
!>
[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 DSYTRF.
!>
[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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDY,NRHS)
!>     On entry, the solution matrix X, as computed by DSYTRS.
!>     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 DLA_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 DOUBLE PRECISION array, dimension (N)
!>     Workspace to hold the intermediate residual.
!>
[in]AYB
!>          AYB is DOUBLE PRECISION array, dimension (N)
!>     Workspace. This can be the same workspace passed for Y_TAIL.
!>
[in]DY
!>          DY is DOUBLE PRECISION array, dimension (N)
!>     Workspace to hold the intermediate solution.
!>
[in]Y_TAIL
!>          Y_TAIL is DOUBLE PRECISION 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 DLA_SYRFSX_EXTENDED had an illegal
!>             value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 389 of file dla_syrfsx_extended.f.

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

◆ dla_syrpvgrw()

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

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

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

Purpose:
!>
!>
!> DLA_SYRPVGRW computes the reciprocal pivot growth factor
!> norm(A)/norm(U). The  norm is used. If this is
!> much less than 1, the stability of the LU factorization of the
!> (equilibrated) matrix A could be poor. This also means that the
!> solution X, estimated condition numbers, and error bounds could be
!> unreliable.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]INFO
!>          INFO is INTEGER
!>     The value of INFO returned from DSYTRF, .i.e., the pivot in
!>     column INFO is exactly 0.
!>
[in]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by DSYTRF.
!>
[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 DSYTRF.
!>
[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 120 of file dla_syrpvgrw.f.

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

◆ dlasyf()

subroutine dlasyf ( character uplo,
integer n,
integer nb,
integer kb,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldw, * ) w,
integer ldw,
integer info )

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

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

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

Definition at line 175 of file dlasyf.f.

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

◆ dlasyf_aa()

subroutine dlasyf_aa ( character uplo,
integer j1,
integer m,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision, dimension( * ) work )

DLASYF_AA

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

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

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

◆ dlasyf_rk()

subroutine dlasyf_rk ( character uplo,
integer n,
integer nb,
integer kb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
double precision, dimension( ldw, * ) w,
integer ldw,
integer info )

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

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

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

◆ dlasyf_rook()

subroutine dlasyf_rook ( character uplo,
integer n,
integer nb,
integer kb,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldw, * ) w,
integer ldw,
integer info )

DLASYF_ROOK *> DLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.

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

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

◆ dsycon()

subroutine dsycon ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DSYCON

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

Purpose:
!>
!> DSYCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a real symmetric matrix A using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by DSYTRF.
!>
[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 DSYTRF.
!>
[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 DOUBLE PRECISION array, dimension (2*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 128 of file dsycon.f.

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

◆ dsycon_3()

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

DSYCON_3

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

Purpose:
!> DSYCON_3 estimates the reciprocal of the condition number (in the
!> 1-norm) of a real symmetric matrix A using the factorization
!> computed by DSYTRF_RK or DSYTRF_BK:
!>
!>    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**T (or L**T) is the transpose of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is symmetric and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!> This routine uses BLAS3 solver DSYTRS_3.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are
!>          stored as an upper or lower triangular matrix:
!>          = 'U':  Upper triangular, form is A = P*U*D*(U**T)*(P**T);
!>          = 'L':  Lower triangular, form is A = P*L*D*(L**T)*(P**T).
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by DSYTRF_RK and DSYTRF_BK:
!>            a) ONLY diagonal elements of the symmetric block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                should be provided on entry in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the symmetric block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is not referenced in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by DSYTRF_RK or DSYTRF_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 DOUBLE PRECISION array, dimension (2*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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.
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 169 of file dsycon_3.f.

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

◆ dsycon_rook()

subroutine dsycon_rook ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DSYCON_ROOK

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

Purpose:
!>
!> DSYCON_ROOK estimates the reciprocal of the condition number (in the
!> 1-norm) of a real symmetric matrix A using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by DSYTRF_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 DSYTRF_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 DOUBLE PRECISION array, dimension (2*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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.
Contributors:
!>
!>   April 2012, Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!>

Definition at line 142 of file dsycon_rook.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* .. Scalar Arguments ..
150 CHARACTER UPLO
151 INTEGER INFO, LDA, N
152 DOUBLE PRECISION ANORM, RCOND
153* ..
154* .. Array Arguments ..
155 INTEGER IPIV( * ), IWORK( * )
156 DOUBLE PRECISION A( LDA, * ), WORK( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 DOUBLE PRECISION ONE, ZERO
163 parameter( one = 1.0d+0, zero = 0.0d+0 )
164* ..
165* .. Local Scalars ..
166 LOGICAL UPPER
167 INTEGER I, KASE
168 DOUBLE PRECISION AINVNM
169* ..
170* .. Local Arrays ..
171 INTEGER ISAVE( 3 )
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 EXTERNAL lsame
176* ..
177* .. External Subroutines ..
178 EXTERNAL dlacn2, dsytrs_rook, xerbla
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC max
182* ..
183* .. Executable Statements ..
184*
185* Test the input parameters.
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( anorm.LT.zero ) THEN
196 info = -6
197 END IF
198 IF( info.NE.0 ) THEN
199 CALL xerbla( 'DSYCON_ROOK', -info )
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 rcond = zero
206 IF( n.EQ.0 ) THEN
207 rcond = one
208 RETURN
209 ELSE IF( anorm.LE.zero ) THEN
210 RETURN
211 END IF
212*
213* Check that the diagonal matrix D is nonsingular.
214*
215 IF( upper ) THEN
216*
217* Upper triangular storage: examine D from bottom to top
218*
219 DO 10 i = n, 1, -1
220 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
221 $ RETURN
222 10 CONTINUE
223 ELSE
224*
225* Lower triangular storage: examine D from top to bottom.
226*
227 DO 20 i = 1, n
228 IF( ipiv( i ).GT.0 .AND. a( i, i ).EQ.zero )
229 $ RETURN
230 20 CONTINUE
231 END IF
232*
233* Estimate the 1-norm of the inverse.
234*
235 kase = 0
236 30 CONTINUE
237 CALL dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
238 IF( kase.NE.0 ) THEN
239*
240* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
241*
242 CALL dsytrs_rook( uplo, n, 1, a, lda, ipiv, work, n, info )
243 GO TO 30
244 END IF
245*
246* Compute the estimate of the reciprocal condition number.
247*
248 IF( ainvnm.NE.zero )
249 $ rcond = ( one / ainvnm ) / anorm
250*
251 RETURN
252*
253* End of DSYCON_ROOK
254*
dsytrs_rook
subroutine dsytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
DSYTRS_ROOK
Definition dsytrs_rook.f:136

◆ dsyconv()

subroutine dsyconv ( character uplo,
character way,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) e,
integer info )

DSYCONV

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

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

Definition at line 113 of file dsyconv.f.

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

◆ dsyconvf()

subroutine dsyconvf ( character uplo,
character way,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
integer info )

DSYCONVF

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

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

Definition at line 205 of file dsyconvf.f.

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

◆ dsyconvf_rook()

subroutine dsyconvf_rook ( character uplo,
character way,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
integer info )

DSYCONVF_ROOK

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

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

Definition at line 196 of file dsyconvf_rook.f.

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

◆ dsyequb()

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

DSYEQUB

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

Purpose:
!>
!> DSYEQUB computes row and column scalings intended to equilibrate a
!> symmetric matrix A (with respect to the Euclidean norm) and reduce
!> its condition number. The scale factors S are computed by the BIN
!> algorithm (see references) so that the scaled matrix B with elements
!> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
!> the smallest possible condition number over all possible diagonal
!> scalings.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The N-by-N symmetric matrix whose scaling factors are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[out]S
!>          S is 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 DOUBLE PRECISION 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 130 of file dsyequb.f.

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

◆ dsygs2()

subroutine dsygs2 ( integer itype,
character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm).

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

Purpose:
!>
!> DSYGS2 reduces a real symmetric-definite generalized eigenproblem
!> to standard form.
!>
!> If ITYPE = 1, the problem is A*x = lambda*B*x,
!> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
!>
!> 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**T or L**T *A*L.
!>
!> B must have been previously factorized as U**T *U or L*L**T by DPOTRF.
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
!>          = 2 or 3: compute U*A*U**T or L**T *A*L.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, 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]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          The triangular factor from the Cholesky factorization of B,
!>          as returned by DPOTRF.
!>
[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 126 of file dsygs2.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, ITYPE, LDA, LDB, N
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ONE, HALF
144 parameter( one = 1.0d0, half = 0.5d0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER K
149 DOUBLE PRECISION AKK, BKK, CT
150* ..
151* .. External Subroutines ..
152 EXTERNAL daxpy, dscal, dsyr2, dtrmv, dtrsv, xerbla
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max
156* ..
157* .. External Functions ..
158 LOGICAL LSAME
159 EXTERNAL lsame
160* ..
161* .. Executable Statements ..
162*
163* Test the input parameters.
164*
165 info = 0
166 upper = lsame( uplo, 'U' )
167 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
168 info = -1
169 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
170 info = -2
171 ELSE IF( n.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 = -7
177 END IF
178 IF( info.NE.0 ) THEN
179 CALL xerbla( 'DSYGS2', -info )
180 RETURN
181 END IF
182*
183 IF( itype.EQ.1 ) THEN
184 IF( upper ) THEN
185*
186* Compute inv(U**T)*A*inv(U)
187*
188 DO 10 k = 1, n
189*
190* Update the upper triangle of A(k:n,k:n)
191*
192 akk = a( k, k )
193 bkk = b( k, k )
194 akk = akk / bkk**2
195 a( k, k ) = akk
196 IF( k.LT.n ) THEN
197 CALL dscal( n-k, one / bkk, a( k, k+1 ), lda )
198 ct = -half*akk
199 CALL daxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ),
200 $ lda )
201 CALL dsyr2( uplo, n-k, -one, a( k, k+1 ), lda,
202 $ b( k, k+1 ), ldb, a( k+1, k+1 ), lda )
203 CALL daxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ),
204 $ lda )
205 CALL dtrsv( uplo, 'Transpose', 'Non-unit', n-k,
206 $ b( k+1, k+1 ), ldb, a( k, k+1 ), lda )
207 END IF
208 10 CONTINUE
209 ELSE
210*
211* Compute inv(L)*A*inv(L**T)
212*
213 DO 20 k = 1, n
214*
215* Update the lower triangle of A(k:n,k:n)
216*
217 akk = a( k, k )
218 bkk = b( k, k )
219 akk = akk / bkk**2
220 a( k, k ) = akk
221 IF( k.LT.n ) THEN
222 CALL dscal( n-k, one / bkk, a( k+1, k ), 1 )
223 ct = -half*akk
224 CALL daxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 )
225 CALL dsyr2( uplo, n-k, -one, a( k+1, k ), 1,
226 $ b( k+1, k ), 1, a( k+1, k+1 ), lda )
227 CALL daxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 )
228 CALL dtrsv( uplo, 'No transpose', 'Non-unit', n-k,
229 $ b( k+1, k+1 ), ldb, a( k+1, k ), 1 )
230 END IF
231 20 CONTINUE
232 END IF
233 ELSE
234 IF( upper ) THEN
235*
236* Compute U*A*U**T
237*
238 DO 30 k = 1, n
239*
240* Update the upper triangle of A(1:k,1:k)
241*
242 akk = a( k, k )
243 bkk = b( k, k )
244 CALL dtrmv( uplo, 'No transpose', 'Non-unit', k-1, b,
245 $ ldb, a( 1, k ), 1 )
246 ct = half*akk
247 CALL daxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 )
248 CALL dsyr2( uplo, k-1, one, a( 1, k ), 1, b( 1, k ), 1,
249 $ a, lda )
250 CALL daxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 )
251 CALL dscal( k-1, bkk, a( 1, k ), 1 )
252 a( k, k ) = akk*bkk**2
253 30 CONTINUE
254 ELSE
255*
256* Compute L**T *A*L
257*
258 DO 40 k = 1, n
259*
260* Update the lower triangle of A(1:k,1:k)
261*
262 akk = a( k, k )
263 bkk = b( k, k )
264 CALL dtrmv( uplo, 'Transpose', 'Non-unit', k-1, b, ldb,
265 $ a( k, 1 ), lda )
266 ct = half*akk
267 CALL daxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda )
268 CALL dsyr2( uplo, k-1, one, a( k, 1 ), lda, b( k, 1 ),
269 $ ldb, a, lda )
270 CALL daxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda )
271 CALL dscal( k-1, bkk, a( k, 1 ), lda )
272 a( k, k ) = akk*bkk**2
273 40 CONTINUE
274 END IF
275 END IF
276 RETURN
277*
278* End of DSYGS2
279*
dtrsv
subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
DTRSV
Definition dtrsv.f:143
dtrmv
subroutine dtrmv(uplo, trans, diag, n, a, lda, x, incx)
DTRMV
Definition dtrmv.f:147
dsyr2
subroutine dsyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
DSYR2
Definition dsyr2.f:147

◆ dsygst()

subroutine dsygst ( integer itype,
character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DSYGST

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

Purpose:
!>
!> DSYGST reduces a real symmetric-definite generalized eigenproblem
!> to standard form.
!>
!> If ITYPE = 1, the problem is A*x = lambda*B*x,
!> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
!>
!> 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**T or L**T*A*L.
!>
!> B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
!>          = 2 or 3: compute U*A*U**T or L**T*A*L.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored and B is factored as
!>                  U**T*U;
!>          = 'L':  Lower triangle of A is stored and B is factored as
!>                  L*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, 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]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          The triangular factor from the Cholesky factorization of B,
!>          as returned by DPOTRF.
!>
[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 126 of file dsygst.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, ITYPE, LDA, LDB, N
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ONE, HALF
144 parameter( one = 1.0d0, half = 0.5d0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER K, KB, NB
149* ..
150* .. External Subroutines ..
151 EXTERNAL dsygs2, dsymm, dsyr2k, dtrmm, dtrsm, xerbla
152* ..
153* .. Intrinsic Functions ..
154 INTRINSIC max, min
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 INTEGER ILAENV
159 EXTERNAL lsame, ilaenv
160* ..
161* .. Executable Statements ..
162*
163* Test the input parameters.
164*
165 info = 0
166 upper = lsame( uplo, 'U' )
167 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
168 info = -1
169 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
170 info = -2
171 ELSE IF( n.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 = -7
177 END IF
178 IF( info.NE.0 ) THEN
179 CALL xerbla( 'DSYGST', -info )
180 RETURN
181 END IF
182*
183* Quick return if possible
184*
185 IF( n.EQ.0 )
186 $ RETURN
187*
188* Determine the block size for this environment.
189*
190 nb = ilaenv( 1, 'DSYGST', uplo, n, -1, -1, -1 )
191*
192 IF( nb.LE.1 .OR. nb.GE.n ) THEN
193*
194* Use unblocked code
195*
196 CALL dsygs2( itype, uplo, n, a, lda, b, ldb, info )
197 ELSE
198*
199* Use blocked code
200*
201 IF( itype.EQ.1 ) THEN
202 IF( upper ) THEN
203*
204* Compute inv(U**T)*A*inv(U)
205*
206 DO 10 k = 1, n, nb
207 kb = min( n-k+1, nb )
208*
209* Update the upper triangle of A(k:n,k:n)
210*
211 CALL dsygs2( itype, uplo, kb, a( k, k ), lda,
212 $ b( k, k ), ldb, info )
213 IF( k+kb.LE.n ) THEN
214 CALL dtrsm( 'Left', uplo, 'Transpose', 'Non-unit',
215 $ kb, n-k-kb+1, one, b( k, k ), ldb,
216 $ a( k, k+kb ), lda )
217 CALL dsymm( 'Left', uplo, kb, n-k-kb+1, -half,
218 $ a( k, k ), lda, b( k, k+kb ), ldb, one,
219 $ a( k, k+kb ), lda )
220 CALL dsyr2k( uplo, 'Transpose', n-k-kb+1, kb, -one,
221 $ a( k, k+kb ), lda, b( k, k+kb ), ldb,
222 $ one, a( k+kb, k+kb ), lda )
223 CALL dsymm( 'Left', uplo, kb, n-k-kb+1, -half,
224 $ a( k, k ), lda, b( k, k+kb ), ldb, one,
225 $ a( k, k+kb ), lda )
226 CALL dtrsm( 'Right', uplo, 'No transpose',
227 $ 'Non-unit', kb, n-k-kb+1, one,
228 $ b( k+kb, k+kb ), ldb, a( k, k+kb ),
229 $ lda )
230 END IF
231 10 CONTINUE
232 ELSE
233*
234* Compute inv(L)*A*inv(L**T)
235*
236 DO 20 k = 1, n, nb
237 kb = min( n-k+1, nb )
238*
239* Update the lower triangle of A(k:n,k:n)
240*
241 CALL dsygs2( itype, uplo, kb, a( k, k ), lda,
242 $ b( k, k ), ldb, info )
243 IF( k+kb.LE.n ) THEN
244 CALL dtrsm( 'Right', uplo, 'Transpose', 'Non-unit',
245 $ n-k-kb+1, kb, one, b( k, k ), ldb,
246 $ a( k+kb, k ), lda )
247 CALL dsymm( 'Right', uplo, n-k-kb+1, kb, -half,
248 $ a( k, k ), lda, b( k+kb, k ), ldb, one,
249 $ a( k+kb, k ), lda )
250 CALL dsyr2k( uplo, 'No transpose', n-k-kb+1, kb,
251 $ -one, a( k+kb, k ), lda, b( k+kb, k ),
252 $ ldb, one, a( k+kb, k+kb ), lda )
253 CALL dsymm( 'Right', uplo, n-k-kb+1, kb, -half,
254 $ a( k, k ), lda, b( k+kb, k ), ldb, one,
255 $ a( k+kb, k ), lda )
256 CALL dtrsm( 'Left', uplo, 'No transpose',
257 $ 'Non-unit', n-k-kb+1, kb, one,
258 $ b( k+kb, k+kb ), ldb, a( k+kb, k ),
259 $ lda )
260 END IF
261 20 CONTINUE
262 END IF
263 ELSE
264 IF( upper ) THEN
265*
266* Compute U*A*U**T
267*
268 DO 30 k = 1, n, nb
269 kb = min( n-k+1, nb )
270*
271* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
272*
273 CALL dtrmm( 'Left', uplo, 'No transpose', 'Non-unit',
274 $ k-1, kb, one, b, ldb, a( 1, k ), lda )
275 CALL dsymm( 'Right', uplo, k-1, kb, half, a( k, k ),
276 $ lda, b( 1, k ), ldb, one, a( 1, k ), lda )
277 CALL dsyr2k( uplo, 'No transpose', k-1, kb, one,
278 $ a( 1, k ), lda, b( 1, k ), ldb, one, a,
279 $ lda )
280 CALL dsymm( 'Right', uplo, k-1, kb, half, a( k, k ),
281 $ lda, b( 1, k ), ldb, one, a( 1, k ), lda )
282 CALL dtrmm( 'Right', uplo, 'Transpose', 'Non-unit',
283 $ k-1, kb, one, b( k, k ), ldb, a( 1, k ),
284 $ lda )
285 CALL dsygs2( itype, uplo, kb, a( k, k ), lda,
286 $ b( k, k ), ldb, info )
287 30 CONTINUE
288 ELSE
289*
290* Compute L**T*A*L
291*
292 DO 40 k = 1, n, nb
293 kb = min( n-k+1, nb )
294*
295* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
296*
297 CALL dtrmm( 'Right', uplo, 'No transpose', 'Non-unit',
298 $ kb, k-1, one, b, ldb, a( k, 1 ), lda )
299 CALL dsymm( 'Left', uplo, kb, k-1, half, a( k, k ),
300 $ lda, b( k, 1 ), ldb, one, a( k, 1 ), lda )
301 CALL dsyr2k( uplo, 'Transpose', k-1, kb, one,
302 $ a( k, 1 ), lda, b( k, 1 ), ldb, one, a,
303 $ lda )
304 CALL dsymm( 'Left', uplo, kb, k-1, half, a( k, k ),
305 $ lda, b( k, 1 ), ldb, one, a( k, 1 ), lda )
306 CALL dtrmm( 'Left', uplo, 'Transpose', 'Non-unit', kb,
307 $ k-1, one, b( k, k ), ldb, a( k, 1 ), lda )
308 CALL dsygs2( itype, uplo, kb, a( k, k ), lda,
309 $ b( k, k ), ldb, info )
310 40 CONTINUE
311 END IF
312 END IF
313 END IF
314 RETURN
315*
316* End of DSYGST
317*
dsygs2
subroutine dsygs2(itype, uplo, n, a, lda, b, ldb, info)
DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorizatio...
Definition dsygs2.f:127
dtrmm
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM
Definition dtrmm.f:177
dtrsm
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181
dsymm
subroutine dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
DSYMM
Definition dsymm.f:189
dsyr2k
subroutine dsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DSYR2K
Definition dsyr2k.f:192

◆ dsyrfs()

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

DSYRFS

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

Purpose:
!>
!> DSYRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is symmetric indefinite, and
!> provides error bounds and backward error estimates for the solution.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!>          upper triangular part of A contains the upper triangular part
!>          of the matrix A, and the strictly lower triangular part of A
!>          is not referenced.  If UPLO = 'L', the leading N-by-N lower
!>          triangular part of A contains the lower triangular part of
!>          the matrix A, and the strictly upper triangular part of A is
!>          not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>          The factored form of the matrix A.  AF contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor U or L from the factorization A = U*D*U**T or
!>          A = L*D*L**T as computed by DSYTRF.
!>
[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 DSYTRF.
!>
[in]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by DSYTRS.
!>          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 DOUBLE PRECISION array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 189 of file dsyrfs.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, LDAF, LDB, LDX, N, NRHS
199* ..
200* .. Array Arguments ..
201 INTEGER IPIV( * ), IWORK( * )
202 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
203 $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
204* ..
205*
206* =====================================================================
207*
208* .. Parameters ..
209 INTEGER ITMAX
210 parameter( itmax = 5 )
211 DOUBLE PRECISION ZERO
212 parameter( zero = 0.0d+0 )
213 DOUBLE PRECISION ONE
214 parameter( one = 1.0d+0 )
215 DOUBLE PRECISION TWO
216 parameter( two = 2.0d+0 )
217 DOUBLE PRECISION THREE
218 parameter( three = 3.0d+0 )
219* ..
220* .. Local Scalars ..
221 LOGICAL UPPER
222 INTEGER COUNT, I, J, K, KASE, NZ
223 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
224* ..
225* .. Local Arrays ..
226 INTEGER ISAVE( 3 )
227* ..
228* .. External Subroutines ..
229 EXTERNAL daxpy, dcopy, dlacn2, dsymv, dsytrs, xerbla
230* ..
231* .. Intrinsic Functions ..
232 INTRINSIC abs, max
233* ..
234* .. External Functions ..
235 LOGICAL LSAME
236 DOUBLE PRECISION DLAMCH
237 EXTERNAL lsame, dlamch
238* ..
239* .. Executable Statements ..
240*
241* Test the input parameters.
242*
243 info = 0
244 upper = lsame( uplo, 'U' )
245 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
246 info = -1
247 ELSE IF( n.LT.0 ) THEN
248 info = -2
249 ELSE IF( nrhs.LT.0 ) THEN
250 info = -3
251 ELSE IF( lda.LT.max( 1, n ) ) THEN
252 info = -5
253 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
254 info = -7
255 ELSE IF( ldb.LT.max( 1, n ) ) THEN
256 info = -10
257 ELSE IF( ldx.LT.max( 1, n ) ) THEN
258 info = -12
259 END IF
260 IF( info.NE.0 ) THEN
261 CALL xerbla( 'DSYRFS', -info )
262 RETURN
263 END IF
264*
265* Quick return if possible
266*
267 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
268 DO 10 j = 1, nrhs
269 ferr( j ) = zero
270 berr( j ) = zero
271 10 CONTINUE
272 RETURN
273 END IF
274*
275* NZ = maximum number of nonzero elements in each row of A, plus 1
276*
277 nz = n + 1
278 eps = dlamch( 'Epsilon' )
279 safmin = dlamch( 'Safe minimum' )
280 safe1 = nz*safmin
281 safe2 = safe1 / eps
282*
283* Do for each right hand side
284*
285 DO 140 j = 1, nrhs
286*
287 count = 1
288 lstres = three
289 20 CONTINUE
290*
291* Loop until stopping criterion is satisfied.
292*
293* Compute residual R = B - A * X
294*
295 CALL dcopy( n, b( 1, j ), 1, work( n+1 ), 1 )
296 CALL dsymv( uplo, n, -one, a, lda, x( 1, j ), 1, one,
297 $ work( n+1 ), 1 )
298*
299* Compute componentwise relative backward error from formula
300*
301* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
302*
303* where abs(Z) is the componentwise absolute value of the matrix
304* or vector Z. If the i-th component of the denominator is less
305* than SAFE2, then SAFE1 is added to the i-th components of the
306* numerator and denominator before dividing.
307*
308 DO 30 i = 1, n
309 work( i ) = abs( b( i, j ) )
310 30 CONTINUE
311*
312* Compute abs(A)*abs(X) + abs(B).
313*
314 IF( upper ) THEN
315 DO 50 k = 1, n
316 s = zero
317 xk = abs( x( k, j ) )
318 DO 40 i = 1, k - 1
319 work( i ) = work( i ) + abs( a( i, k ) )*xk
320 s = s + abs( a( i, k ) )*abs( x( i, j ) )
321 40 CONTINUE
322 work( k ) = work( k ) + abs( a( k, k ) )*xk + s
323 50 CONTINUE
324 ELSE
325 DO 70 k = 1, n
326 s = zero
327 xk = abs( x( k, j ) )
328 work( k ) = work( k ) + abs( a( k, k ) )*xk
329 DO 60 i = k + 1, n
330 work( i ) = work( i ) + abs( a( i, k ) )*xk
331 s = s + abs( a( i, k ) )*abs( x( i, j ) )
332 60 CONTINUE
333 work( k ) = work( k ) + s
334 70 CONTINUE
335 END IF
336 s = zero
337 DO 80 i = 1, n
338 IF( work( i ).GT.safe2 ) THEN
339 s = max( s, abs( work( n+i ) ) / work( i ) )
340 ELSE
341 s = max( s, ( abs( work( n+i ) )+safe1 ) /
342 $ ( work( i )+safe1 ) )
343 END IF
344 80 CONTINUE
345 berr( j ) = s
346*
347* Test stopping criterion. Continue iterating if
348* 1) The residual BERR(J) is larger than machine epsilon, and
349* 2) BERR(J) decreased by at least a factor of 2 during the
350* last iteration, and
351* 3) At most ITMAX iterations tried.
352*
353 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
354 $ count.LE.itmax ) THEN
355*
356* Update solution and try again.
357*
358 CALL dsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
359 $ info )
360 CALL daxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 )
361 lstres = berr( j )
362 count = count + 1
363 GO TO 20
364 END IF
365*
366* Bound error from formula
367*
368* norm(X - XTRUE) / norm(X) .le. FERR =
369* norm( abs(inv(A))*
370* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
371*
372* where
373* norm(Z) is the magnitude of the largest component of Z
374* inv(A) is the inverse of A
375* abs(Z) is the componentwise absolute value of the matrix or
376* vector Z
377* NZ is the maximum number of nonzeros in any row of A, plus 1
378* EPS is machine epsilon
379*
380* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
381* is incremented by SAFE1 if the i-th component of
382* abs(A)*abs(X) + abs(B) is less than SAFE2.
383*
384* Use DLACN2 to estimate the infinity-norm of the matrix
385* inv(A) * diag(W),
386* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
387*
388 DO 90 i = 1, n
389 IF( work( i ).GT.safe2 ) THEN
390 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
391 ELSE
392 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
393 END IF
394 90 CONTINUE
395*
396 kase = 0
397 100 CONTINUE
398 CALL dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),
399 $ kase, isave )
400 IF( kase.NE.0 ) THEN
401 IF( kase.EQ.1 ) THEN
402*
403* Multiply by diag(W)*inv(A**T).
404*
405 CALL dsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
406 $ info )
407 DO 110 i = 1, n
408 work( n+i ) = work( i )*work( n+i )
409 110 CONTINUE
410 ELSE IF( kase.EQ.2 ) THEN
411*
412* Multiply by inv(A)*diag(W).
413*
414 DO 120 i = 1, n
415 work( n+i ) = work( i )*work( n+i )
416 120 CONTINUE
417 CALL dsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
418 $ info )
419 END IF
420 GO TO 100
421 END IF
422*
423* Normalize error.
424*
425 lstres = zero
426 DO 130 i = 1, n
427 lstres = max( lstres, abs( x( i, j ) ) )
428 130 CONTINUE
429 IF( lstres.NE.zero )
430 $ ferr( j ) = ferr( j ) / lstres
431*
432 140 CONTINUE
433*
434 RETURN
435*
436* End of DSYRFS
437*

◆ dsyrfsx()

subroutine dsyrfsx ( character uplo,
character equed,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
double precision, dimension( * ) s,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, 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,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DSYRFSX

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

Purpose:
!>
!>    DSYRFSX improves the computed solution to a system of linear
!>    equations when the coefficient matrix is symmetric indefinite, and
!>    provides error bounds and backward error estimates for the
!>    solution.  In addition to normwise error bound, the code provides
!>    maximum componentwise error bound if possible.  See comments for
!>    ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
!>
!>    The original system of linear equations may have been equilibrated
!>    before calling this routine, as described by arguments EQUED and S
!>    below. In this case, the solution and error bounds returned are
!>    for the original unequilibrated system.
!> 
!>     Some optional parameters are bundled in the PARAMS array.  These
!>     settings determine how refinement is performed, but often the
!>     defaults are acceptable.  If the defaults are acceptable, users
!>     can pass NPARAMS = 0 which prevents the source code from accessing
!>     the PARAMS argument.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>       = 'U':  Upper triangle of A is stored;
!>       = 'L':  Lower triangle of A is stored.
!>
[in]EQUED
!>          EQUED is CHARACTER*1
!>     Specifies the form of equilibration that was done to A
!>     before calling this routine. This is needed to compute
!>     the solution and error bounds correctly.
!>       = 'N':  No equilibration
!>       = 'Y':  Both row and column equilibration, i.e., A has been
!>               replaced by diag(S) * A * diag(S).
!>               The right hand side B has been changed accordingly.
!>
[in]N
!>          N is INTEGER
!>     The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>     The number of right hand sides, i.e., the number of columns
!>     of the matrices B and X.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!>     upper triangular part of A contains the upper triangular
!>     part of the matrix A, and the strictly lower triangular
!>     part of A is not referenced.  If UPLO = 'L', the leading
!>     N-by-N lower triangular part of A contains the lower
!>     triangular part of the matrix A, and the strictly upper
!>     triangular part of A is not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>     The factored form of the matrix A.  AF contains the block
!>     diagonal matrix D and the multipliers used to obtain the
!>     factor U or L from the factorization A = U*D*U**T or A =
!>     L*D*L**T as computed by DSYTRF.
!>
[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 DSYTRF.
!>
[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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>     On entry, the solution matrix X, as computed by DGETRS.
!>     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 DOUBLE PRECISION array, dimension (4*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit. The solution to every right-hand side is
!>         guaranteed.
!>       < 0:  If INFO = -i, the i-th argument had an illegal value
!>       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization
!>         has been completed, but the factor U is exactly singular, so
!>         the solution and error bounds could not be computed. RCOND = 0
!>         is returned.
!>       = N+J: The solution corresponding to the Jth right-hand side is
!>         not guaranteed. The solutions corresponding to other right-
!>         hand sides K with K > J may not be guaranteed as well, but
!>         only the first such right-hand side is reported. If a small
!>         componentwise error is not requested (PARAMS(3) = 0.0) then
!>         the Jth right-hand side is the first with a normwise error
!>         bound that is not guaranteed (the smallest J such
!>         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
!>         the Jth right-hand side is the first with either a normwise or
!>         componentwise error bound that is not guaranteed (the smallest
!>         J such that either ERR_BNDS_NORM(J,1) = 0.0 or
!>         ERR_BNDS_COMP(J,1) = 0.0). See the definition of
!>         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
!>         about all of the right-hand sides check ERR_BNDS_NORM or
!>         ERR_BNDS_COMP.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 398 of file dsyrfsx.f.

402*
403* -- LAPACK computational routine --
404* -- LAPACK is a software package provided by Univ. of Tennessee, --
405* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
406*
407* .. Scalar Arguments ..
408 CHARACTER UPLO, EQUED
409 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
410 $ N_ERR_BNDS
411 DOUBLE PRECISION RCOND
412* ..
413* .. Array Arguments ..
414 INTEGER IPIV( * ), IWORK( * )
415 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
416 $ X( LDX, * ), WORK( * )
417 DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ),
418 $ ERR_BNDS_NORM( NRHS, * ),
419 $ ERR_BNDS_COMP( NRHS, * )
420* ..
421*
422* ==================================================================
423*
424* .. Parameters ..
425 DOUBLE PRECISION ZERO, ONE
426 parameter( zero = 0.0d+0, one = 1.0d+0 )
427 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
428 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
429 DOUBLE PRECISION DZTHRESH_DEFAULT
430 parameter( itref_default = 1.0d+0 )
431 parameter( ithresh_default = 10.0d+0 )
432 parameter( componentwise_default = 1.0d+0 )
433 parameter( rthresh_default = 0.5d+0 )
434 parameter( dzthresh_default = 0.25d+0 )
435 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
436 $ LA_LINRX_CWISE_I
437 parameter( la_linrx_itref_i = 1,
438 $ la_linrx_ithresh_i = 2 )
439 parameter( la_linrx_cwise_i = 3 )
440 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
441 $ LA_LINRX_RCOND_I
442 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
443 parameter( la_linrx_rcond_i = 3 )
444* ..
445* .. Local Scalars ..
446 CHARACTER(1) NORM
447 LOGICAL RCEQU
448 INTEGER J, PREC_TYPE, REF_TYPE, N_NORMS
449 DOUBLE PRECISION ANORM, RCOND_TMP
450 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
451 LOGICAL IGNORE_CWISE
452 INTEGER ITHRESH
453 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
454* ..
455* .. External Subroutines ..
456 EXTERNAL xerbla, dsycon, dla_syrfsx_extended
457* ..
458* .. Intrinsic Functions ..
459 INTRINSIC max, sqrt
460* ..
461* .. External Functions ..
462 EXTERNAL lsame, ilaprec
463 EXTERNAL dlamch, dlansy, dla_syrcond
464 DOUBLE PRECISION DLAMCH, DLANSY, DLA_SYRCOND
465 LOGICAL LSAME
466 INTEGER ILAPREC
467* ..
468* .. Executable Statements ..
469*
470* Check the input parameters.
471*
472 info = 0
473 ref_type = int( itref_default )
474 IF ( nparams .GE. la_linrx_itref_i ) THEN
475 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 ) THEN
476 params( la_linrx_itref_i ) = itref_default
477 ELSE
478 ref_type = params( la_linrx_itref_i )
479 END IF
480 END IF
481*
482* Set default parameters.
483*
484 illrcond_thresh = dble( n )*dlamch( 'Epsilon' )
485 ithresh = int( ithresh_default )
486 rthresh = rthresh_default
487 unstable_thresh = dzthresh_default
488 ignore_cwise = componentwise_default .EQ. 0.0d+0
489*
490 IF ( nparams.GE.la_linrx_ithresh_i ) THEN
491 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 ) THEN
492 params( la_linrx_ithresh_i ) = ithresh
493 ELSE
494 ithresh = int( params( la_linrx_ithresh_i ) )
495 END IF
496 END IF
497 IF ( nparams.GE.la_linrx_cwise_i ) THEN
498 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 ) THEN
499 IF ( ignore_cwise ) THEN
500 params( la_linrx_cwise_i ) = 0.0d+0
501 ELSE
502 params( la_linrx_cwise_i ) = 1.0d+0
503 END IF
504 ELSE
505 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
506 END IF
507 END IF
508 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 ) THEN
509 n_norms = 0
510 ELSE IF ( ignore_cwise ) THEN
511 n_norms = 1
512 ELSE
513 n_norms = 2
514 END IF
515*
516 rcequ = lsame( equed, 'Y' )
517*
518* Test input parameters.
519*
520 IF ( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
521 info = -1
522 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed, 'N' ) ) THEN
523 info = -2
524 ELSE IF( n.LT.0 ) THEN
525 info = -3
526 ELSE IF( nrhs.LT.0 ) THEN
527 info = -4
528 ELSE IF( lda.LT.max( 1, n ) ) THEN
529 info = -6
530 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
531 info = -8
532 ELSE IF( ldb.LT.max( 1, n ) ) THEN
533 info = -12
534 ELSE IF( ldx.LT.max( 1, n ) ) THEN
535 info = -14
536 END IF
537 IF( info.NE.0 ) THEN
538 CALL xerbla( 'DSYRFSX', -info )
539 RETURN
540 END IF
541*
542* Quick return if possible.
543*
544 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
545 rcond = 1.0d+0
546 DO j = 1, nrhs
547 berr( j ) = 0.0d+0
548 IF ( n_err_bnds .GE. 1 ) THEN
549 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
550 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
551 END IF
552 IF ( n_err_bnds .GE. 2 ) THEN
553 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
554 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
555 END IF
556 IF ( n_err_bnds .GE. 3 ) THEN
557 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
558 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
559 END IF
560 END DO
561 RETURN
562 END IF
563*
564* Default to failure.
565*
566 rcond = 0.0d+0
567 DO j = 1, nrhs
568 berr( j ) = 1.0d+0
569 IF ( n_err_bnds .GE. 1 ) THEN
570 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
571 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
572 END IF
573 IF ( n_err_bnds .GE. 2 ) THEN
574 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
575 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
576 END IF
577 IF ( n_err_bnds .GE. 3 ) THEN
578 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
579 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
580 END IF
581 END DO
582*
583* Compute the norm of A and the reciprocal of the condition
584* number of A.
585*
586 norm = 'I'
587 anorm = dlansy( norm, uplo, n, a, lda, work )
588 CALL dsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work,
589 $ iwork, info )
590*
591* Perform refinement on each right-hand side
592*
593 IF ( ref_type .NE. 0 ) THEN
594
595 prec_type = ilaprec( 'E' )
596
597 CALL dla_syrfsx_extended( prec_type, uplo, n,
598 $ nrhs, a, lda, af, ldaf, ipiv, rcequ, s, b,
599 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
600 $ work( n+1 ), work( 1 ), work( 2*n+1 ), work( 1 ), 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 = dla_syrcond( uplo, n, a, lda, af, ldaf, ipiv,
612 $ -1, s, info, work, iwork )
613 ELSE
614 rcond_tmp = dla_syrcond( uplo, n, a, lda, af, ldaf, ipiv,
615 $ 0, s, info, work, iwork )
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 = dla_syrcond( uplo, n, a, lda, af, ldaf, ipiv,
660 $ 1, x(1,j), info, work, iwork )
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 DSYRFSX
696*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
ilaprec
integer function ilaprec(prec)
ILAPREC
Definition ilaprec.f:58
dlansy
double precision function dlansy(norm, uplo, n, a, lda, work)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansy.f:122
dsycon
subroutine dsycon(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
DSYCON
Definition dsycon.f:130
dla_syrfsx_extended
subroutine dla_syrfsx_extended(prec_type, uplo, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
DLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric inde...
Definition dla_syrfsx_extended.f:396

◆ dsytd2()

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

DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm).

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

Purpose:
!>
!> DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
!> form T by an orthogonal similarity transformation: Q**T * A * Q = T.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, 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 orthogonal
!>          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 orthogonal 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 DOUBLE PRECISION 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**T
!>
!>  where tau is a real scalar, and v is a real 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**T
!>
!>  where tau is a real scalar, and v is a real 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 172 of file dsytd2.f.

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

◆ dsytf2()

subroutine dsytf2 ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

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

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

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

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

◆ dsytf2_rk()

subroutine dsytf2_rk ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
integer info )

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

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

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

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

◆ dsytf2_rook()

subroutine dsytf2_rook ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

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

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

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

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

◆ dsytrd()

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

DSYTRD

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

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

◆ dsytrd_2stage()

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

DSYTRD_2STAGE

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

Purpose:
!>
!> DSYTRD_2STAGE reduces a real symmetric matrix A to real symmetric
!> tridiagonal form T by a orthogonal similarity transformation:
!> Q1**T Q2**T* 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, 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 orthogonal
!>          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 orthogonal 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 DOUBLE PRECISION array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors of 
!>          the first stage (see Further Details).
!>
[out]HOUS2
!>          HOUS2 is DOUBLE PRECISION 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 DOUBLE PRECISION 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 dsytrd_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 DOUBLE PRECISION 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 ..
248 EXTERNAL xerbla, dsytrd_sy2sb, dsytrd_sb2st
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, 'DSYTRD_2STAGE', vect, n, -1, -1, -1 )
267 ib = ilaenv2stage( 2, 'DSYTRD_2STAGE', vect, n, kd, -1, -1 )
268 lhmin = ilaenv2stage( 3, 'DSYTRD_2STAGE', vect, n, kd, ib, -1 )
269 lwmin = ilaenv2stage( 4, 'DSYTRD_2STAGE', vect, n, kd, ib, -1 )
270* WRITE(*,*),'DSYTRD_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( 'DSYTRD_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 dsytrd_sy2sb( uplo, n, kd, a, lda, work( abpos ), ldab,
313 $ tau, work( wpos ), lwrk, info )
314 IF( info.NE.0 ) THEN
315 CALL xerbla( 'DSYTRD_SY2SB', -info )
316 RETURN
317 END IF
318 CALL dsytrd_sb2st( '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( 'DSYTRD_SB2ST', -info )
323 RETURN
324 END IF
325*
326*
327 hous2( 1 ) = lhmin
328 work( 1 ) = lwmin
329 RETURN
330*
331* End of DSYTRD_2STAGE
332*
dsytrd_sb2st
subroutine dsytrd_sb2st(stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T
Definition dsytrd_sb2st.F:230
ilaenv2stage
integer function ilaenv2stage(ispec, name, opts, n1, n2, n3, n4)
ILAENV2STAGE
Definition ilaenv2stage.f:149
dsytrd_sy2sb
subroutine dsytrd_sy2sb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
DSYTRD_SY2SB
Definition dsytrd_sy2sb.f:243

◆ dsytrd_sy2sb()

subroutine dsytrd_sy2sb ( character uplo,
integer n,
integer kd,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRD_SY2SB

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

Purpose:
!>
!> DSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric
!> band-diagonal form AB by a orthogonal similarity transformation:
!> Q**T * 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, 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 orthogonal
!>          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 orthogonal 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 DOUBLE PRECISION array, dimension (LDAB,N)
!>          On exit, the upper or lower triangle of the symmetric 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 DOUBLE PRECISION array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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)**T . . . H(2)**T H(1)**T, where k = n-kd.
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real 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**T
!>
!>  where tau is a real scalar, and v is a real 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 dsytrd_sy2sb.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 DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ),
256 $ TAU( * ), WORK( * )
257* ..
258*
259* =====================================================================
260*
261* .. Parameters ..
262 DOUBLE PRECISION RONE
263 DOUBLE PRECISION ZERO, ONE, HALF
264 parameter( rone = 1.0d+0,
265 $ zero = 0.0d+0,
266 $ one = 1.0d+0,
267 $ half = 0.5d+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, dsyr2k, dsymm, dgemm, dcopy,
278 $ dlarft, dgelqf, dgeqrf, dlaset
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, 'DSYTRD_SY2SB', '', 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( 'DSYTRD_SY2SB', -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 dcopy( 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 dcopy( 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 dlaset( "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 dgelqf( 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 dcopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
382 20 CONTINUE
383*
384 CALL dlaset( 'Lower', pk, pk, zero, one,
385 $ a( i, i+kd ), lda )
386*
387* Form the matrix T
388*
389 CALL dlarft( 'Forward', 'Rowwise', pn, pk,
390 $ a( i, i+kd ), lda, tau( i ),
391 $ work( tpos ), ldt )
392*
393* Compute W:
394*
395 CALL dgemm( '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 dsymm( 'Right', uplo, pk, pn,
401 $ one, a( i+kd, i+kd ), lda,
402 $ work( s2pos ), lds2,
403 $ zero, work( wpos ), ldw )
404*
405 CALL dgemm( 'No transpose', 'Conjugate', pk, pk, pn,
406 $ one, work( wpos ), ldw,
407 $ work( s2pos ), lds2,
408 $ zero, work( s1pos ), lds1 )
409*
410 CALL dgemm( '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 dsyr2k( 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 dcopy( 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 dgeqrf( 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 dcopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
450 50 CONTINUE
451*
452 CALL dlaset( 'Upper', pk, pk, zero, one,
453 $ a( i+kd, i ), lda )
454*
455* Form the matrix T
456*
457 CALL dlarft( 'Forward', 'Columnwise', pn, pk,
458 $ a( i+kd, i ), lda, tau( i ),
459 $ work( tpos ), ldt )
460*
461* Compute W:
462*
463 CALL dgemm( '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 dsymm( 'Left', uplo, pn, pk,
469 $ one, a( i+kd, i+kd ), lda,
470 $ work( s2pos ), lds2,
471 $ zero, work( wpos ), ldw )
472*
473 CALL dgemm( 'Conjugate', 'No transpose', pk, pk, pn,
474 $ one, work( s2pos ), lds2,
475 $ work( wpos ), ldw,
476 $ zero, work( s1pos ), lds1 )
477*
478 CALL dgemm( '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 dsyr2k( 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 DCOPY( 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 dcopy( 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 DSYTRD_SY2SB
513*
dgelqf
subroutine dgelqf(m, n, a, lda, tau, work, lwork, info)
DGELQF
Definition dgelqf.f:143
dgeqrf
subroutine dgeqrf(m, n, a, lda, tau, work, lwork, info)
DGEQRF
Definition dgeqrf.f:146
dlarft
subroutine dlarft(direct, storev, n, k, v, ldv, tau, t, ldt)
DLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition dlarft.f:163

◆ dsytrf()

subroutine dsytrf ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRF

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

Purpose:
!>
!> DSYTRF computes the factorization of a real symmetric matrix A using
!> the Bunch-Kaufman diagonal pivoting method.  The form of the
!> factorization is
!>
!>    A = U**T*D*U  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and D is symmetric and block diagonal with
!> 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L (see below for further details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>          interchanged and D(k,k) is a 1-by-1 diagonal block.
!>          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!>          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!>          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!>          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!>          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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**T*D*U, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>

Definition at line 181 of file dsytrf.f.

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

◆ dsytrf_aa()

subroutine dsytrf_aa ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRF_AA

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

Purpose:
!>
!> DSYTRF_AA computes the factorization of a real symmetric matrix A
!> using the Aasen's algorithm.  The form of the factorization is
!>
!>    A = U**T*T*U  or  A = L*T*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and T is a symmetric tridiagonal matrix.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the tridiagonal matrix is stored in the diagonals
!>          and the subdiagonals of A just below (or above) the diagonals,
!>          and L is stored below (or above) the subdiaonals, when UPLO
!>          is 'L' (or 'U').
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dsytrf_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 DOUBLE PRECISION A( LDA, * ), WORK( * )
146* ..
147*
148* =====================================================================
149* .. Parameters ..
150 DOUBLE PRECISION ZERO, ONE
151 parameter( zero = 0.0d+0, one = 1.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 DOUBLE PRECISION ALPHA
158* ..
159* .. External Functions ..
160 LOGICAL LSAME
161 INTEGER ILAENV
162 EXTERNAL lsame, ilaenv
163* ..
164* .. External Subroutines ..
165 EXTERNAL dlasyf_aa, dgemm, dgemv, dscal, dcopy, dswap,
166 $ xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max
170* ..
171* .. Executable Statements ..
172*
173* Determine the block size
174*
175 nb = ilaenv( 1, 'DSYTRF_AA', uplo, n, -1, -1, -1 )
176*
177* Test the input parameters.
178*
179 info = 0
180 upper = lsame( uplo, 'U' )
181 lquery = ( lwork.EQ.-1 )
182 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
183 info = -1
184 ELSE IF( n.LT.0 ) THEN
185 info = -2
186 ELSE IF( lda.LT.max( 1, n ) ) THEN
187 info = -4
188 ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN
189 info = -7
190 END IF
191*
192 IF( info.EQ.0 ) THEN
193 lwkopt = (nb+1)*n
194 work( 1 ) = lwkopt
195 END IF
196*
197 IF( info.NE.0 ) THEN
198 CALL xerbla( 'DSYTRF_AA', -info )
199 RETURN
200 ELSE IF( lquery ) THEN
201 RETURN
202 END IF
203*
204* Quick return
205*
206 IF ( n.EQ.0 ) THEN
207 RETURN
208 ENDIF
209 ipiv( 1 ) = 1
210 IF ( n.EQ.1 ) THEN
211 RETURN
212 END IF
213*
214* Adjust block size based on the workspace size
215*
216 IF( lwork.LT.((1+nb)*n) ) THEN
217 nb = ( lwork-n ) / n
218 END IF
219*
220 IF( upper ) THEN
221*
222* .....................................................
223* Factorize A as U**T*D*U using the upper triangle of A
224* .....................................................
225*
226* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N))
227*
228 CALL dcopy( 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 DLASYF;
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 dlasyf_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 dswap( j1-k1-2, a( 1, j2 ), 1,
262 $ a( 1, ipiv(j2) ), 1 )
263 END IF
264 END DO
265 j = j + jb
266*
267* Trailing submatrix update, where
268* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
269* WORK stores the current block of the auxiriarly matrix H
270*
271 IF( j.LT.n ) THEN
272*
273* If first panel and JB=1 (NB=1), then nothing to do
274*
275 IF( j1.GT.1 .OR. jb.GT.1 ) THEN
276*
277* Merge rank-1 update with BLAS-3 update
278*
279 alpha = a( j, j+1 )
280 a( j, j+1 ) = one
281 CALL dcopy( n-j, a( j-1, j+1 ), lda,
282 $ work( (j+1-j1+1)+jb*n ), 1 )
283 CALL dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
284*
285* K1 identifies if the previous column of the panel has been
286* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
287* while K1=0 and K2=1 for the rest
288*
289 IF( j1.GT.1 ) THEN
290*
291* Not first panel
292*
293 k2 = 1
294 ELSE
295*
296* First panel
297*
298 k2 = 0
299*
300* First update skips the first column
301*
302 jb = jb - 1
303 END IF
304*
305 DO j2 = j+1, n, nb
306 nj = min( nb, n-j2+1 )
307*
308* Update (J2, J2) diagonal block with DGEMV
309*
310 j3 = j2
311 DO mj = nj-1, 1, -1
312 CALL dgemv( 'No transpose', mj, jb+1,
313 $ -one, work( j3-j1+1+k1*n ), n,
314 $ a( j1-k2, j3 ), 1,
315 $ one, a( j3, j3 ), lda )
316 j3 = j3 + 1
317 END DO
318*
319* Update off-diagonal block of J2-th block row with DGEMM
320*
321 CALL dgemm( 'Transpose', 'Transpose',
322 $ nj, n-j3+1, jb+1,
323 $ -one, a( j1-k2, j2 ), lda,
324 $ work( j3-j1+1+k1*n ), n,
325 $ one, a( j2, j3 ), lda )
326 END DO
327*
328* Recover T( J, J+1 )
329*
330 a( j, j+1 ) = alpha
331 END IF
332*
333* WORK(J+1, 1) stores H(J+1, 1)
334*
335 CALL dcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 )
336 END IF
337 GO TO 10
338 ELSE
339*
340* .....................................................
341* Factorize A as L*D*L**T using the lower triangle of A
342* .....................................................
343*
344* copy first column A(1:N, 1) into H(1:N, 1)
345* (stored in WORK(1:N))
346*
347 CALL dcopy( n, a( 1, 1 ), 1, work( 1 ), 1 )
348*
349* J is the main loop index, increasing from 1 to N in steps of
350* JB, where JB is the number of columns factorized by DLASYF;
351* JB is either NB, or N-J+1 for the last block
352*
353 j = 0
354 11 CONTINUE
355 IF( j.GE.n )
356 $ GO TO 20
357*
358* each step of the main loop
359* J is the last column of the previous panel
360* J1 is the first column of the current panel
361* K1 identifies if the previous column of the panel has been
362* explicitly stored, e.g., K1=1 for the first panel, and
363* K1=0 for the rest
364*
365 j1 = j+1
366 jb = min( n-j1+1, nb )
367 k1 = max(1, j)-j
368*
369* Panel factorization
370*
371 CALL dlasyf_aa( uplo, 2-k1, n-j, jb,
372 $ a( j+1, max(1, j) ), lda,
373 $ ipiv( j+1 ), work, n, work( n*nb+1 ) )
374*
375* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot)
376*
377 DO j2 = j+2, min(n, j+jb+1)
378 ipiv( j2 ) = ipiv( j2 ) + j
379 IF( (j2.NE.ipiv(j2)) .AND. ((j1-k1).GT.2) ) THEN
380 CALL dswap( j1-k1-2, a( j2, 1 ), lda,
381 $ a( ipiv(j2), 1 ), lda )
382 END IF
383 END DO
384 j = j + jb
385*
386* Trailing submatrix update, where
387* A(J2+1, J1-1) stores L(J2+1, J1) and
388* WORK(J2+1, 1) stores H(J2+1, 1)
389*
390 IF( j.LT.n ) THEN
391*
392* if first panel and JB=1 (NB=1), then nothing to do
393*
394 IF( j1.GT.1 .OR. jb.GT.1 ) THEN
395*
396* Merge rank-1 update with BLAS-3 update
397*
398 alpha = a( j+1, j )
399 a( j+1, j ) = one
400 CALL dcopy( n-j, a( j+1, j-1 ), 1,
401 $ work( (j+1-j1+1)+jb*n ), 1 )
402 CALL dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
403*
404* K1 identifies if the previous column of the panel has been
405* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
406* while K1=0 and K2=1 for the rest
407*
408 IF( j1.GT.1 ) THEN
409*
410* Not first panel
411*
412 k2 = 1
413 ELSE
414*
415* First panel
416*
417 k2 = 0
418*
419* First update skips the first column
420*
421 jb = jb - 1
422 END IF
423*
424 DO j2 = j+1, n, nb
425 nj = min( nb, n-j2+1 )
426*
427* Update (J2, J2) diagonal block with DGEMV
428*
429 j3 = j2
430 DO mj = nj-1, 1, -1
431 CALL dgemv( 'No transpose', mj, jb+1,
432 $ -one, work( j3-j1+1+k1*n ), n,
433 $ a( j3, j1-k2 ), lda,
434 $ one, a( j3, j3 ), 1 )
435 j3 = j3 + 1
436 END DO
437*
438* Update off-diagonal block in J2-th block column with DGEMM
439*
440 CALL dgemm( 'No transpose', 'Transpose',
441 $ n-j3+1, nj, jb+1,
442 $ -one, work( j3-j1+1+k1*n ), n,
443 $ a( j2, j1-k2 ), lda,
444 $ one, a( j3, j2 ), lda )
445 END DO
446*
447* Recover T( J+1, J )
448*
449 a( j+1, j ) = alpha
450 END IF
451*
452* WORK(J+1, 1) stores H(J+1, 1)
453*
454 CALL dcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 )
455 END IF
456 GO TO 11
457 END IF
458*
459 20 CONTINUE
460 work( 1 ) = lwkopt
461 RETURN
462*
463* End of DSYTRF_AA
464*
dlasyf_aa
subroutine dlasyf_aa(uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
DLASYF_AA
Definition dlasyf_aa.f:144

◆ dsytrf_aa_2stage()

subroutine dsytrf_aa_2stage ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tb,
integer ltb,
integer, dimension( * ) ipiv,
integer, dimension( * ) ipiv2,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRF_AA_2STAGE

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

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

Definition at line 158 of file dsytrf_aa_2stage.f.

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

◆ dsytrf_rk()

subroutine dsytrf_rk ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

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

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

Purpose:
!> DSYTRF_RK computes the factorization of a real symmetric matrix A
!> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!>
!>    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**T (or L**T) is the transpose of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is symmetric and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!> For more information see Further Details section.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.
!>            If UPLO = 'U': the leading N-by-N upper triangular part
!>            of A contains the upper triangular part of the matrix A,
!>            and the strictly lower triangular part of A is not
!>            referenced.
!>
!>            If UPLO = 'L': the leading N-by-N lower triangular part
!>            of A contains the lower triangular part of the matrix A,
!>            and the strictly upper triangular part of A is not
!>            referenced.
!>
!>          On exit, contains:
!>            a) ONLY diagonal elements of the symmetric block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                are stored on exit in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          On exit, contains the superdiagonal (or subdiagonal)
!>          elements of the symmetric block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is set to 0 in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          IPIV describes the permutation matrix P in the factorization
!>          of matrix A as follows. The absolute value of IPIV(k)
!>          represents the index of row and column that were
!>          interchanged with the k-th row and column. The value of UPLO
!>          describes the order in which the interchanges were applied.
!>          Also, the sign of IPIV represents the block structure of
!>          the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
!>          diagonal blocks which correspond to 1 or 2 interchanges
!>          at each factorization step. For more info see Further
!>          Details section.
!>
!>          If UPLO = 'U',
!>          ( in factorization order, k decreases from N to 1 ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the matrix A(1:N,1:N);
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k-1) < 0 means:
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k-1) != k-1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k-1) = k-1, no interchange occurred.
!>
!>            c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
!>          If UPLO = 'L',
!>          ( in factorization order, k increases from 1 to N ):
!>            a) A single positive entry IPIV(k) > 0 means:
!>               D(k,k) is a 1-by-1 diagonal block.
!>               If IPIV(k) != k, rows and columns k and IPIV(k) were
!>               interchanged in the matrix A(1:N,1:N).
!>               If IPIV(k) = k, no interchange occurred.
!>
!>            b) A pair of consecutive negative entries
!>               IPIV(k) < 0 and IPIV(k+1) < 0 means:
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>               (NOTE: negative entries in IPIV appear ONLY in pairs).
!>               1) If -IPIV(k) != k, rows and columns
!>                  k and -IPIV(k) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k) = k, no interchange occurred.
!>               2) If -IPIV(k+1) != k+1, rows and columns
!>                  k-1 and -IPIV(k-1) were interchanged
!>                  in the matrix A(1:N,1:N).
!>                  If -IPIV(k+1) = k+1, no interchange occurred.
!>
!>            c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
!>
!>            d) NOTE: Any entry IPIV(k) is always NONZERO on output.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dsytrf_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 DOUBLE PRECISION 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 dlasyf_rk, dsytf2_rk, dswap, 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, 'DSYTRF_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( 'DSYTRF_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, 'DSYTRF_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 DLASYF_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 dlasyf_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 dsytf2_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 dswap( 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 DLASYF_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 dlasyf_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 dsytf2_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 dswap( 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 DSYTRF_RK
494*
dlasyf_rk
subroutine dlasyf_rk(uplo, n, nb, kb, a, lda, e, ipiv, w, ldw, info)
DLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-...
Definition dlasyf_rk.f:262
dsytf2_rk
subroutine dsytf2_rk(uplo, n, a, lda, e, ipiv, info)
DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Ka...
Definition dsytf2_rk.f:241

◆ dsytrf_rook()

subroutine dsytrf_rook ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRF_ROOK

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

Purpose:
!>
!> DSYTRF_ROOK computes the factorization of a real symmetric matrix A
!> using the bounded Bunch-Kaufman () diagonal pivoting method.
!> The form of the factorization is
!>
!>    A = U*D*U**T  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and D is symmetric and block diagonal with
!> 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, the block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L (see below for further details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>
!>          If UPLO = 'U':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>               If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
!>               columns k and -IPIV(k) were interchanged and rows and
!>               columns k-1 and -IPIV(k-1) were inerchaged,
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>               If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
!>               columns k and -IPIV(k) were interchanged and rows and
!>               columns k+1 and -IPIV(k+1) were inerchaged,
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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:
!>
!>   April 2012, Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!>

Definition at line 207 of file dsytrf_rook.f.

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

◆ dsytri()

subroutine dsytri ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer info )

DSYTRI

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

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

◆ dsytri2()

subroutine dsytri2 ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRI2

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

Purpose:
!>
!> DSYTRI2 computes the inverse of a DOUBLE PRECISION symmetric indefinite matrix
!> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
!> DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace
!> before calling DSYTRI2X 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 DOUBLE PRECISION 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 DSYTRF.
!>
!>          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 DSYTRF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dsytri2.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 DOUBLE PRECISION 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 dsytri, dsytri2x, 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, 'DSYTRI2', 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( 'DSYTRI2', -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 dsytri( uplo, n, a, lda, ipiv, work, info )
195 ELSE
196 CALL dsytri2x( uplo, n, a, lda, ipiv, work, nbmax, info )
197 END IF
198 RETURN
199*
200* End of DSYTRI2
201*
dsytri
subroutine dsytri(uplo, n, a, lda, ipiv, work, info)
DSYTRI
Definition dsytri.f:114
dsytri2x
subroutine dsytri2x(uplo, n, a, lda, ipiv, work, nb, info)
DSYTRI2X
Definition dsytri2x.f:120

◆ dsytri2x()

subroutine dsytri2x ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( n+nb+1,* ) work,
integer nb,
integer info )

DSYTRI2X

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

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

◆ dsytri_3()

subroutine dsytri_3 ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRI_3

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

Purpose:
!> DSYTRI_3 computes the inverse of a real symmetric indefinite
!> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK:
!>
!>     A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**T (or L**T) is the transpose of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is symmetric and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> DSYTRI_3 sets the leading dimension of the workspace  before calling
!> DSYTRI_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 DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, diagonal of the block diagonal matrix D and
!>          factors U or L as computed by DSYTRF_RK and DSYTRF_BK:
!>            a) ONLY diagonal elements of the symmetric block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                should be provided on entry in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!>
!>          On exit, if INFO = 0, the symmetric inverse of the original
!>          matrix.
!>             If UPLO = 'U': the upper triangular part of the inverse
!>             is formed and the part of A below the diagonal is not
!>             referenced;
!>             If UPLO = 'L': the lower triangular part of the inverse
!>             is formed and the part of A above the diagonal is not
!>             referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the symmetric block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is not referenced in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by DSYTRF_RK or DSYTRF_BK.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dsytri_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 DOUBLE PRECISION 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 dsytri_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, 'DSYTRI_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( 'DSYTRI_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 dsytri_3x( uplo, n, a, lda, e, ipiv, work, nb, info )
238*
239 work( 1 ) = lwkopt
240*
241 RETURN
242*
243* End of DSYTRI_3
244*
dsytri_3x
subroutine dsytri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
DSYTRI_3X
Definition dsytri_3x.f:159

◆ dsytri_3x()

subroutine dsytri_3x ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
double precision, dimension( n+nb+1, * ) work,
integer nb,
integer info )

DSYTRI_3X

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

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

◆ dsytri_rook()

subroutine dsytri_rook ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer info )

DSYTRI_ROOK

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

Purpose:
!>
!> DSYTRI_ROOK computes the inverse of a real symmetric
!> matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!> computed by DSYTRF_ROOK.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION 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 DSYTRF_ROOK.
!>
!>          On exit, if INFO = 0, the (symmetric) inverse of the original
!>          matrix.  If UPLO = 'U', the upper triangular part of the
!>          inverse is formed and the part of A below the diagonal is not
!>          referenced; if UPLO = 'L' the lower triangular part of the
!>          inverse is formed and the part of A above the diagonal is
!>          not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by DSYTRF_ROOK.
!>
[out]WORK
!>          WORK 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
!>          > 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:
!>
!>   April 2012, Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!>

Definition at line 128 of file dsytri_rook.f.

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

◆ dsytrs()

subroutine dsytrs ( character uplo,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DSYTRS

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

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

◆ dsytrs2()

subroutine dsytrs2 ( character uplo,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) work,
integer info )

DSYTRS2

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

Purpose:
!>
!> DSYTRS2 solves a system of linear equations A*X = B with a real
!> symmetric matrix A using the factorization A = U*D*U**T or
!> A = L*D*L**T computed by DSYTRF and converted by DSYCONV.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by DSYTRF.
!>          Note that A is input / output. This might be counter-intuitive,
!>          and one may think that A is input only. A is input / output. This
!>          is because, at the start of the subroutine, we permute A in a
!>           form and then we permute A back to its original form at
!>          the end.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by DSYTRF.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 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
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 130 of file dsytrs2.f.

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

◆ dsytrs_3()

subroutine dsytrs_3 ( character uplo,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DSYTRS_3

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

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

◆ dsytrs_aa()

subroutine dsytrs_aa ( character uplo,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) work,
integer lwork,
integer info )

DSYTRS_AA

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

Purpose:
!>
!> DSYTRS_AA solves a system of linear equations A*X = B with a real
!> symmetric matrix A using the factorization A = U**T*T*U or
!> A = L*T*L**T computed by DSYTRF_AA.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U**T*T*U;
!>          = 'L':  Lower triangular, form is A = L*T*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of factors computed by DSYTRF_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 DSYTRF_AA.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,3*N-2).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file dsytrs_aa.f.

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

◆ dsytrs_aa_2stage()

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

DSYTRS_AA_2STAGE

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

Purpose:
!>
!> DSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a real
!> symmetric matrix A using the factorization A = U**T*T*U or
!> A = L*T*L**T computed by DSYTRF_AA_2STAGE.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U**T*T*U;
!>          = 'L':  Lower triangular, form is A = L*T*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of factors computed by DSYTRF_AA_2STAGE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is DOUBLE PRECISION array, dimension (LTB)
!>          Details of factors computed by DSYTRF_AA_2STAGE.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          DSYTRF_AA_2STAGE.
!>
[in]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          DSYTRF_AA_2STAGE.
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file dsytrs_aa_2stage.f.

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

◆ dsytrs_rook()

subroutine dsytrs_rook ( character uplo,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DSYTRS_ROOK

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

Purpose:
!>
!> DSYTRS_ROOK solves a system of linear equations A*X = B with
!> a real symmetric matrix A using the factorization A = U*D*U**T or
!> A = L*D*L**T computed by DSYTRF_ROOK.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by DSYTRF_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 DSYTRF_ROOK.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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:
!>
!>   April 2012, Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!>

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

◆ dtgsyl()

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

DTGSYL

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

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

Definition at line 296 of file dtgsyl.f.

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

◆ dtrsyl()

subroutine dtrsyl ( character trana,
character tranb,
integer isgn,
integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision scale,
integer info )

DTRSYL

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

Purpose:
!>
!> DTRSYL solves the real Sylvester matrix equation:
!>
!>    op(A)*X + X*op(B) = scale*C or
!>    op(A)*X - X*op(B) = scale*C,
!>
!> where op(A) = A or A**T, and  A and B are both upper quasi-
!> triangular. A is M-by-M and B is N-by-N; the right hand side C and
!> the solution X are M-by-N; and scale is an output scale factor, set
!> <= 1 to avoid overflow in X.
!>
!> A and B must be in Schur canonical form (as returned by DHSEQR), that
!> is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
!> each 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!>
Parameters
[in]TRANA
!>          TRANA is CHARACTER*1
!>          Specifies the option op(A):
!>          = 'N': op(A) = A    (No transpose)
!>          = 'T': op(A) = A**T (Transpose)
!>          = 'C': op(A) = A**H (Conjugate transpose = Transpose)
!>
[in]TRANB
!>          TRANB is CHARACTER*1
!>          Specifies the option op(B):
!>          = 'N': op(B) = B    (No transpose)
!>          = 'T': op(B) = B**T (Transpose)
!>          = 'C': op(B) = B**H (Conjugate transpose = Transpose)
!>
[in]ISGN
!>          ISGN is INTEGER
!>          Specifies the sign in the equation:
!>          = +1: solve op(A)*X + X*op(B) = scale*C
!>          = -1: solve op(A)*X - X*op(B) = scale*C
!>
[in]M
!>          M is INTEGER
!>          The order of the matrix A, and the number of rows in the
!>          matrices X and C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B, and the number of columns in the
!>          matrices X and C. N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,M)
!>          The upper quasi-triangular matrix A, in Schur canonical form.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          The upper quasi-triangular matrix B, in Schur canonical form.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N right hand side matrix C.
!>          On exit, C is overwritten by the solution matrix X.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M)
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scale factor, scale, set <= 1 to avoid overflow in X.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1: A and B have common or very close eigenvalues; perturbed
!>               values were used to solve the equation (but the matrices
!>               A and B are unchanged).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 162 of file dtrsyl.f.

164*
165* -- LAPACK computational routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 CHARACTER TRANA, TRANB
171 INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
172 DOUBLE PRECISION SCALE
173* ..
174* .. Array Arguments ..
175 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * )
176* ..
177*
178* =====================================================================
179*
180* .. Parameters ..
181 DOUBLE PRECISION ZERO, ONE
182 parameter( zero = 0.0d+0, one = 1.0d+0 )
183* ..
184* .. Local Scalars ..
185 LOGICAL NOTRNA, NOTRNB
186 INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
187 DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
188 $ SMLNUM, SUML, SUMR, XNORM
189* ..
190* .. Local Arrays ..
191 DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
192* ..
193* .. External Functions ..
194 LOGICAL LSAME
195 DOUBLE PRECISION DDOT, DLAMCH, DLANGE
196 EXTERNAL lsame, ddot, dlamch, dlange
197* ..
198* .. External Subroutines ..
199 EXTERNAL dlabad, dlaln2, dlasy2, dscal, xerbla
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC abs, dble, max, min
203* ..
204* .. Executable Statements ..
205*
206* Decode and Test input parameters
207*
208 notrna = lsame( trana, 'N' )
209 notrnb = lsame( tranb, 'N' )
210*
211 info = 0
212 IF( .NOT.notrna .AND. .NOT.lsame( trana, 'T' ) .AND. .NOT.
213 $ lsame( trana, 'C' ) ) THEN
214 info = -1
215 ELSE IF( .NOT.notrnb .AND. .NOT.lsame( tranb, 'T' ) .AND. .NOT.
216 $ lsame( tranb, 'C' ) ) THEN
217 info = -2
218 ELSE IF( isgn.NE.1 .AND. isgn.NE.-1 ) THEN
219 info = -3
220 ELSE IF( m.LT.0 ) THEN
221 info = -4
222 ELSE IF( n.LT.0 ) THEN
223 info = -5
224 ELSE IF( lda.LT.max( 1, m ) ) THEN
225 info = -7
226 ELSE IF( ldb.LT.max( 1, n ) ) THEN
227 info = -9
228 ELSE IF( ldc.LT.max( 1, m ) ) THEN
229 info = -11
230 END IF
231 IF( info.NE.0 ) THEN
232 CALL xerbla( 'DTRSYL', -info )
233 RETURN
234 END IF
235*
236* Quick return if possible
237*
238 scale = one
239 IF( m.EQ.0 .OR. n.EQ.0 )
240 $ RETURN
241*
242* Set constants to control overflow
243*
244 eps = dlamch( 'P' )
245 smlnum = dlamch( 'S' )
246 bignum = one / smlnum
247 CALL dlabad( smlnum, bignum )
248 smlnum = smlnum*dble( m*n ) / eps
249 bignum = one / smlnum
250*
251 smin = max( smlnum, eps*dlange( 'M', m, m, a, lda, dum ),
252 $ eps*dlange( 'M', n, n, b, ldb, dum ) )
253*
254 sgn = isgn
255*
256 IF( notrna .AND. notrnb ) THEN
257*
258* Solve A*X + ISGN*X*B = scale*C.
259*
260* The (K,L)th block of X is determined starting from
261* bottom-left corner column by column by
262*
263* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
264*
265* Where
266* M L-1
267* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
268* I=K+1 J=1
269*
270* Start column loop (index = L)
271* L1 (L2) : column index of the first (first) row of X(K,L).
272*
273 lnext = 1
274 DO 60 l = 1, n
275 IF( l.LT.lnext )
276 $ GO TO 60
277 IF( l.EQ.n ) THEN
278 l1 = l
279 l2 = l
280 ELSE
281 IF( b( l+1, l ).NE.zero ) THEN
282 l1 = l
283 l2 = l + 1
284 lnext = l + 2
285 ELSE
286 l1 = l
287 l2 = l
288 lnext = l + 1
289 END IF
290 END IF
291*
292* Start row loop (index = K)
293* K1 (K2): row index of the first (last) row of X(K,L).
294*
295 knext = m
296 DO 50 k = m, 1, -1
297 IF( k.GT.knext )
298 $ GO TO 50
299 IF( k.EQ.1 ) THEN
300 k1 = k
301 k2 = k
302 ELSE
303 IF( a( k, k-1 ).NE.zero ) THEN
304 k1 = k - 1
305 k2 = k
306 knext = k - 2
307 ELSE
308 k1 = k
309 k2 = k
310 knext = k - 1
311 END IF
312 END IF
313*
314 IF( l1.EQ.l2 .AND. k1.EQ.k2 ) THEN
315 suml = ddot( m-k1, a( k1, min( k1+1, m ) ), lda,
316 $ c( min( k1+1, m ), l1 ), 1 )
317 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
318 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
319 scaloc = one
320*
321 a11 = a( k1, k1 ) + sgn*b( l1, l1 )
322 da11 = abs( a11 )
323 IF( da11.LE.smin ) THEN
324 a11 = smin
325 da11 = smin
326 info = 1
327 END IF
328 db = abs( vec( 1, 1 ) )
329 IF( da11.LT.one .AND. db.GT.one ) THEN
330 IF( db.GT.bignum*da11 )
331 $ scaloc = one / db
332 END IF
333 x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11
334*
335 IF( scaloc.NE.one ) THEN
336 DO 10 j = 1, n
337 CALL dscal( m, scaloc, c( 1, j ), 1 )
338 10 CONTINUE
339 scale = scale*scaloc
340 END IF
341 c( k1, l1 ) = x( 1, 1 )
342*
343 ELSE IF( l1.EQ.l2 .AND. k1.NE.k2 ) THEN
344*
345 suml = ddot( m-k2, a( k1, min( k2+1, m ) ), lda,
346 $ c( min( k2+1, m ), l1 ), 1 )
347 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
348 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
349*
350 suml = ddot( m-k2, a( k2, min( k2+1, m ) ), lda,
351 $ c( min( k2+1, m ), l1 ), 1 )
352 sumr = ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
353 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
354*
355 CALL dlaln2( .false., 2, 1, smin, one, a( k1, k1 ),
356 $ lda, one, one, vec, 2, -sgn*b( l1, l1 ),
357 $ zero, x, 2, scaloc, xnorm, ierr )
358 IF( ierr.NE.0 )
359 $ info = 1
360*
361 IF( scaloc.NE.one ) THEN
362 DO 20 j = 1, n
363 CALL dscal( m, scaloc, c( 1, j ), 1 )
364 20 CONTINUE
365 scale = scale*scaloc
366 END IF
367 c( k1, l1 ) = x( 1, 1 )
368 c( k2, l1 ) = x( 2, 1 )
369*
370 ELSE IF( l1.NE.l2 .AND. k1.EQ.k2 ) THEN
371*
372 suml = ddot( m-k1, a( k1, min( k1+1, m ) ), lda,
373 $ c( min( k1+1, m ), l1 ), 1 )
374 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
375 vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
376*
377 suml = ddot( m-k1, a( k1, min( k1+1, m ) ), lda,
378 $ c( min( k1+1, m ), l2 ), 1 )
379 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
380 vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
381*
382 CALL dlaln2( .true., 2, 1, smin, one, b( l1, l1 ),
383 $ ldb, one, one, vec, 2, -sgn*a( k1, k1 ),
384 $ zero, x, 2, scaloc, xnorm, ierr )
385 IF( ierr.NE.0 )
386 $ info = 1
387*
388 IF( scaloc.NE.one ) THEN
389 DO 30 j = 1, n
390 CALL dscal( m, scaloc, c( 1, j ), 1 )
391 30 CONTINUE
392 scale = scale*scaloc
393 END IF
394 c( k1, l1 ) = x( 1, 1 )
395 c( k1, l2 ) = x( 2, 1 )
396*
397 ELSE IF( l1.NE.l2 .AND. k1.NE.k2 ) THEN
398*
399 suml = ddot( m-k2, a( k1, min( k2+1, m ) ), lda,
400 $ c( min( k2+1, m ), l1 ), 1 )
401 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
402 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
403*
404 suml = ddot( m-k2, a( k1, min( k2+1, m ) ), lda,
405 $ c( min( k2+1, m ), l2 ), 1 )
406 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
407 vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr )
408*
409 suml = ddot( m-k2, a( k2, min( k2+1, m ) ), lda,
410 $ c( min( k2+1, m ), l1 ), 1 )
411 sumr = ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
412 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
413*
414 suml = ddot( m-k2, a( k2, min( k2+1, m ) ), lda,
415 $ c( min( k2+1, m ), l2 ), 1 )
416 sumr = ddot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 )
417 vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr )
418*
419 CALL dlasy2( .false., .false., isgn, 2, 2,
420 $ a( k1, k1 ), lda, b( l1, l1 ), ldb, vec,
421 $ 2, scaloc, x, 2, xnorm, ierr )
422 IF( ierr.NE.0 )
423 $ info = 1
424*
425 IF( scaloc.NE.one ) THEN
426 DO 40 j = 1, n
427 CALL dscal( m, scaloc, c( 1, j ), 1 )
428 40 CONTINUE
429 scale = scale*scaloc
430 END IF
431 c( k1, l1 ) = x( 1, 1 )
432 c( k1, l2 ) = x( 1, 2 )
433 c( k2, l1 ) = x( 2, 1 )
434 c( k2, l2 ) = x( 2, 2 )
435 END IF
436*
437 50 CONTINUE
438*
439 60 CONTINUE
440*
441 ELSE IF( .NOT.notrna .AND. notrnb ) THEN
442*
443* Solve A**T *X + ISGN*X*B = scale*C.
444*
445* The (K,L)th block of X is determined starting from
446* upper-left corner column by column by
447*
448* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
449*
450* Where
451* K-1 T L-1
452* R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
453* I=1 J=1
454*
455* Start column loop (index = L)
456* L1 (L2): column index of the first (last) row of X(K,L)
457*
458 lnext = 1
459 DO 120 l = 1, n
460 IF( l.LT.lnext )
461 $ GO TO 120
462 IF( l.EQ.n ) THEN
463 l1 = l
464 l2 = l
465 ELSE
466 IF( b( l+1, l ).NE.zero ) THEN
467 l1 = l
468 l2 = l + 1
469 lnext = l + 2
470 ELSE
471 l1 = l
472 l2 = l
473 lnext = l + 1
474 END IF
475 END IF
476*
477* Start row loop (index = K)
478* K1 (K2): row index of the first (last) row of X(K,L)
479*
480 knext = 1
481 DO 110 k = 1, m
482 IF( k.LT.knext )
483 $ GO TO 110
484 IF( k.EQ.m ) THEN
485 k1 = k
486 k2 = k
487 ELSE
488 IF( a( k+1, k ).NE.zero ) THEN
489 k1 = k
490 k2 = k + 1
491 knext = k + 2
492 ELSE
493 k1 = k
494 k2 = k
495 knext = k + 1
496 END IF
497 END IF
498*
499 IF( l1.EQ.l2 .AND. k1.EQ.k2 ) THEN
500 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
501 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
502 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
503 scaloc = one
504*
505 a11 = a( k1, k1 ) + sgn*b( l1, l1 )
506 da11 = abs( a11 )
507 IF( da11.LE.smin ) THEN
508 a11 = smin
509 da11 = smin
510 info = 1
511 END IF
512 db = abs( vec( 1, 1 ) )
513 IF( da11.LT.one .AND. db.GT.one ) THEN
514 IF( db.GT.bignum*da11 )
515 $ scaloc = one / db
516 END IF
517 x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11
518*
519 IF( scaloc.NE.one ) THEN
520 DO 70 j = 1, n
521 CALL dscal( m, scaloc, c( 1, j ), 1 )
522 70 CONTINUE
523 scale = scale*scaloc
524 END IF
525 c( k1, l1 ) = x( 1, 1 )
526*
527 ELSE IF( l1.EQ.l2 .AND. k1.NE.k2 ) THEN
528*
529 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
530 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
531 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
532*
533 suml = ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
534 sumr = ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
535 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
536*
537 CALL dlaln2( .true., 2, 1, smin, one, a( k1, k1 ),
538 $ lda, one, one, vec, 2, -sgn*b( l1, l1 ),
539 $ zero, x, 2, scaloc, xnorm, ierr )
540 IF( ierr.NE.0 )
541 $ info = 1
542*
543 IF( scaloc.NE.one ) THEN
544 DO 80 j = 1, n
545 CALL dscal( m, scaloc, c( 1, j ), 1 )
546 80 CONTINUE
547 scale = scale*scaloc
548 END IF
549 c( k1, l1 ) = x( 1, 1 )
550 c( k2, l1 ) = x( 2, 1 )
551*
552 ELSE IF( l1.NE.l2 .AND. k1.EQ.k2 ) THEN
553*
554 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
555 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
556 vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
557*
558 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
559 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
560 vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
561*
562 CALL dlaln2( .true., 2, 1, smin, one, b( l1, l1 ),
563 $ ldb, one, one, vec, 2, -sgn*a( k1, k1 ),
564 $ zero, x, 2, scaloc, xnorm, ierr )
565 IF( ierr.NE.0 )
566 $ info = 1
567*
568 IF( scaloc.NE.one ) THEN
569 DO 90 j = 1, n
570 CALL dscal( m, scaloc, c( 1, j ), 1 )
571 90 CONTINUE
572 scale = scale*scaloc
573 END IF
574 c( k1, l1 ) = x( 1, 1 )
575 c( k1, l2 ) = x( 2, 1 )
576*
577 ELSE IF( l1.NE.l2 .AND. k1.NE.k2 ) THEN
578*
579 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
580 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
581 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
582*
583 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
584 sumr = ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
585 vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr )
586*
587 suml = ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
588 sumr = ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
589 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
590*
591 suml = ddot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 )
592 sumr = ddot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 )
593 vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr )
594*
595 CALL dlasy2( .true., .false., isgn, 2, 2, a( k1, k1 ),
596 $ lda, b( l1, l1 ), ldb, vec, 2, scaloc, x,
597 $ 2, xnorm, ierr )
598 IF( ierr.NE.0 )
599 $ info = 1
600*
601 IF( scaloc.NE.one ) THEN
602 DO 100 j = 1, n
603 CALL dscal( m, scaloc, c( 1, j ), 1 )
604 100 CONTINUE
605 scale = scale*scaloc
606 END IF
607 c( k1, l1 ) = x( 1, 1 )
608 c( k1, l2 ) = x( 1, 2 )
609 c( k2, l1 ) = x( 2, 1 )
610 c( k2, l2 ) = x( 2, 2 )
611 END IF
612*
613 110 CONTINUE
614 120 CONTINUE
615*
616 ELSE IF( .NOT.notrna .AND. .NOT.notrnb ) THEN
617*
618* Solve A**T*X + ISGN*X*B**T = scale*C.
619*
620* The (K,L)th block of X is determined starting from
621* top-right corner column by column by
622*
623* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L)
624*
625* Where
626* K-1 N
627* R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T].
628* I=1 J=L+1
629*
630* Start column loop (index = L)
631* L1 (L2): column index of the first (last) row of X(K,L)
632*
633 lnext = n
634 DO 180 l = n, 1, -1
635 IF( l.GT.lnext )
636 $ GO TO 180
637 IF( l.EQ.1 ) THEN
638 l1 = l
639 l2 = l
640 ELSE
641 IF( b( l, l-1 ).NE.zero ) THEN
642 l1 = l - 1
643 l2 = l
644 lnext = l - 2
645 ELSE
646 l1 = l
647 l2 = l
648 lnext = l - 1
649 END IF
650 END IF
651*
652* Start row loop (index = K)
653* K1 (K2): row index of the first (last) row of X(K,L)
654*
655 knext = 1
656 DO 170 k = 1, m
657 IF( k.LT.knext )
658 $ GO TO 170
659 IF( k.EQ.m ) THEN
660 k1 = k
661 k2 = k
662 ELSE
663 IF( a( k+1, k ).NE.zero ) THEN
664 k1 = k
665 k2 = k + 1
666 knext = k + 2
667 ELSE
668 k1 = k
669 k2 = k
670 knext = k + 1
671 END IF
672 END IF
673*
674 IF( l1.EQ.l2 .AND. k1.EQ.k2 ) THEN
675 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
676 sumr = ddot( n-l1, c( k1, min( l1+1, n ) ), ldc,
677 $ b( l1, min( l1+1, n ) ), ldb )
678 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
679 scaloc = one
680*
681 a11 = a( k1, k1 ) + sgn*b( l1, l1 )
682 da11 = abs( a11 )
683 IF( da11.LE.smin ) THEN
684 a11 = smin
685 da11 = smin
686 info = 1
687 END IF
688 db = abs( vec( 1, 1 ) )
689 IF( da11.LT.one .AND. db.GT.one ) THEN
690 IF( db.GT.bignum*da11 )
691 $ scaloc = one / db
692 END IF
693 x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11
694*
695 IF( scaloc.NE.one ) THEN
696 DO 130 j = 1, n
697 CALL dscal( m, scaloc, c( 1, j ), 1 )
698 130 CONTINUE
699 scale = scale*scaloc
700 END IF
701 c( k1, l1 ) = x( 1, 1 )
702*
703 ELSE IF( l1.EQ.l2 .AND. k1.NE.k2 ) THEN
704*
705 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
706 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
707 $ b( l1, min( l2+1, n ) ), ldb )
708 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
709*
710 suml = ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
711 sumr = ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,
712 $ b( l1, min( l2+1, n ) ), ldb )
713 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
714*
715 CALL dlaln2( .true., 2, 1, smin, one, a( k1, k1 ),
716 $ lda, one, one, vec, 2, -sgn*b( l1, l1 ),
717 $ zero, x, 2, scaloc, xnorm, ierr )
718 IF( ierr.NE.0 )
719 $ info = 1
720*
721 IF( scaloc.NE.one ) THEN
722 DO 140 j = 1, n
723 CALL dscal( m, scaloc, c( 1, j ), 1 )
724 140 CONTINUE
725 scale = scale*scaloc
726 END IF
727 c( k1, l1 ) = x( 1, 1 )
728 c( k2, l1 ) = x( 2, 1 )
729*
730 ELSE IF( l1.NE.l2 .AND. k1.EQ.k2 ) THEN
731*
732 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
733 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
734 $ b( l1, min( l2+1, n ) ), ldb )
735 vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
736*
737 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
738 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
739 $ b( l2, min( l2+1, n ) ), ldb )
740 vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
741*
742 CALL dlaln2( .false., 2, 1, smin, one, b( l1, l1 ),
743 $ ldb, one, one, vec, 2, -sgn*a( k1, k1 ),
744 $ zero, x, 2, scaloc, xnorm, ierr )
745 IF( ierr.NE.0 )
746 $ info = 1
747*
748 IF( scaloc.NE.one ) THEN
749 DO 150 j = 1, n
750 CALL dscal( m, scaloc, c( 1, j ), 1 )
751 150 CONTINUE
752 scale = scale*scaloc
753 END IF
754 c( k1, l1 ) = x( 1, 1 )
755 c( k1, l2 ) = x( 2, 1 )
756*
757 ELSE IF( l1.NE.l2 .AND. k1.NE.k2 ) THEN
758*
759 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
760 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
761 $ b( l1, min( l2+1, n ) ), ldb )
762 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
763*
764 suml = ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
765 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
766 $ b( l2, min( l2+1, n ) ), ldb )
767 vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr )
768*
769 suml = ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
770 sumr = ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,
771 $ b( l1, min( l2+1, n ) ), ldb )
772 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
773*
774 suml = ddot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 )
775 sumr = ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,
776 $ b( l2, min( l2+1, n ) ), ldb )
777 vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr )
778*
779 CALL dlasy2( .true., .true., isgn, 2, 2, a( k1, k1 ),
780 $ lda, b( l1, l1 ), ldb, vec, 2, scaloc, x,
781 $ 2, xnorm, ierr )
782 IF( ierr.NE.0 )
783 $ info = 1
784*
785 IF( scaloc.NE.one ) THEN
786 DO 160 j = 1, n
787 CALL dscal( m, scaloc, c( 1, j ), 1 )
788 160 CONTINUE
789 scale = scale*scaloc
790 END IF
791 c( k1, l1 ) = x( 1, 1 )
792 c( k1, l2 ) = x( 1, 2 )
793 c( k2, l1 ) = x( 2, 1 )
794 c( k2, l2 ) = x( 2, 2 )
795 END IF
796*
797 170 CONTINUE
798 180 CONTINUE
799*
800 ELSE IF( notrna .AND. .NOT.notrnb ) THEN
801*
802* Solve A*X + ISGN*X*B**T = scale*C.
803*
804* The (K,L)th block of X is determined starting from
805* bottom-right corner column by column by
806*
807* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L)
808*
809* Where
810* M N
811* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T].
812* I=K+1 J=L+1
813*
814* Start column loop (index = L)
815* L1 (L2): column index of the first (last) row of X(K,L)
816*
817 lnext = n
818 DO 240 l = n, 1, -1
819 IF( l.GT.lnext )
820 $ GO TO 240
821 IF( l.EQ.1 ) THEN
822 l1 = l
823 l2 = l
824 ELSE
825 IF( b( l, l-1 ).NE.zero ) THEN
826 l1 = l - 1
827 l2 = l
828 lnext = l - 2
829 ELSE
830 l1 = l
831 l2 = l
832 lnext = l - 1
833 END IF
834 END IF
835*
836* Start row loop (index = K)
837* K1 (K2): row index of the first (last) row of X(K,L)
838*
839 knext = m
840 DO 230 k = m, 1, -1
841 IF( k.GT.knext )
842 $ GO TO 230
843 IF( k.EQ.1 ) THEN
844 k1 = k
845 k2 = k
846 ELSE
847 IF( a( k, k-1 ).NE.zero ) THEN
848 k1 = k - 1
849 k2 = k
850 knext = k - 2
851 ELSE
852 k1 = k
853 k2 = k
854 knext = k - 1
855 END IF
856 END IF
857*
858 IF( l1.EQ.l2 .AND. k1.EQ.k2 ) THEN
859 suml = ddot( m-k1, a( k1, min( k1+1, m ) ), lda,
860 $ c( min( k1+1, m ), l1 ), 1 )
861 sumr = ddot( n-l1, c( k1, min( l1+1, n ) ), ldc,
862 $ b( l1, min( l1+1, n ) ), ldb )
863 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
864 scaloc = one
865*
866 a11 = a( k1, k1 ) + sgn*b( l1, l1 )
867 da11 = abs( a11 )
868 IF( da11.LE.smin ) THEN
869 a11 = smin
870 da11 = smin
871 info = 1
872 END IF
873 db = abs( vec( 1, 1 ) )
874 IF( da11.LT.one .AND. db.GT.one ) THEN
875 IF( db.GT.bignum*da11 )
876 $ scaloc = one / db
877 END IF
878 x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11
879*
880 IF( scaloc.NE.one ) THEN
881 DO 190 j = 1, n
882 CALL dscal( m, scaloc, c( 1, j ), 1 )
883 190 CONTINUE
884 scale = scale*scaloc
885 END IF
886 c( k1, l1 ) = x( 1, 1 )
887*
888 ELSE IF( l1.EQ.l2 .AND. k1.NE.k2 ) THEN
889*
890 suml = ddot( m-k2, a( k1, min( k2+1, m ) ), lda,
891 $ c( min( k2+1, m ), l1 ), 1 )
892 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
893 $ b( l1, min( l2+1, n ) ), ldb )
894 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
895*
896 suml = ddot( m-k2, a( k2, min( k2+1, m ) ), lda,
897 $ c( min( k2+1, m ), l1 ), 1 )
898 sumr = ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,
899 $ b( l1, min( l2+1, n ) ), ldb )
900 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
901*
902 CALL dlaln2( .false., 2, 1, smin, one, a( k1, k1 ),
903 $ lda, one, one, vec, 2, -sgn*b( l1, l1 ),
904 $ zero, x, 2, scaloc, xnorm, ierr )
905 IF( ierr.NE.0 )
906 $ info = 1
907*
908 IF( scaloc.NE.one ) THEN
909 DO 200 j = 1, n
910 CALL dscal( m, scaloc, c( 1, j ), 1 )
911 200 CONTINUE
912 scale = scale*scaloc
913 END IF
914 c( k1, l1 ) = x( 1, 1 )
915 c( k2, l1 ) = x( 2, 1 )
916*
917 ELSE IF( l1.NE.l2 .AND. k1.EQ.k2 ) THEN
918*
919 suml = ddot( m-k1, a( k1, min( k1+1, m ) ), lda,
920 $ c( min( k1+1, m ), l1 ), 1 )
921 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
922 $ b( l1, min( l2+1, n ) ), ldb )
923 vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
924*
925 suml = ddot( m-k1, a( k1, min( k1+1, m ) ), lda,
926 $ c( min( k1+1, m ), l2 ), 1 )
927 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
928 $ b( l2, min( l2+1, n ) ), ldb )
929 vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
930*
931 CALL dlaln2( .false., 2, 1, smin, one, b( l1, l1 ),
932 $ ldb, one, one, vec, 2, -sgn*a( k1, k1 ),
933 $ zero, x, 2, scaloc, xnorm, ierr )
934 IF( ierr.NE.0 )
935 $ info = 1
936*
937 IF( scaloc.NE.one ) THEN
938 DO 210 j = 1, n
939 CALL dscal( m, scaloc, c( 1, j ), 1 )
940 210 CONTINUE
941 scale = scale*scaloc
942 END IF
943 c( k1, l1 ) = x( 1, 1 )
944 c( k1, l2 ) = x( 2, 1 )
945*
946 ELSE IF( l1.NE.l2 .AND. k1.NE.k2 ) THEN
947*
948 suml = ddot( m-k2, a( k1, min( k2+1, m ) ), lda,
949 $ c( min( k2+1, m ), l1 ), 1 )
950 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
951 $ b( l1, min( l2+1, n ) ), ldb )
952 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
953*
954 suml = ddot( m-k2, a( k1, min( k2+1, m ) ), lda,
955 $ c( min( k2+1, m ), l2 ), 1 )
956 sumr = ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,
957 $ b( l2, min( l2+1, n ) ), ldb )
958 vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr )
959*
960 suml = ddot( m-k2, a( k2, min( k2+1, m ) ), lda,
961 $ c( min( k2+1, m ), l1 ), 1 )
962 sumr = ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,
963 $ b( l1, min( l2+1, n ) ), ldb )
964 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
965*
966 suml = ddot( m-k2, a( k2, min( k2+1, m ) ), lda,
967 $ c( min( k2+1, m ), l2 ), 1 )
968 sumr = ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,
969 $ b( l2, min( l2+1, n ) ), ldb )
970 vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr )
971*
972 CALL dlasy2( .false., .true., isgn, 2, 2, a( k1, k1 ),
973 $ lda, b( l1, l1 ), ldb, vec, 2, scaloc, x,
974 $ 2, xnorm, ierr )
975 IF( ierr.NE.0 )
976 $ info = 1
977*
978 IF( scaloc.NE.one ) THEN
979 DO 220 j = 1, n
980 CALL dscal( m, scaloc, c( 1, j ), 1 )
981 220 CONTINUE
982 scale = scale*scaloc
983 END IF
984 c( k1, l1 ) = x( 1, 1 )
985 c( k1, l2 ) = x( 1, 2 )
986 c( k2, l1 ) = x( 2, 1 )
987 c( k2, l2 ) = x( 2, 2 )
988 END IF
989*
990 230 CONTINUE
991 240 CONTINUE
992*
993 END IF
994*
995 RETURN
996*
997* End of DTRSYL
998*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
dlange
double precision function dlange(norm, m, n, a, lda, work)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlange.f:114
dlaln2
subroutine dlaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition dlaln2.f:218
dlasy2
subroutine dlasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition dlasy2.f:174