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

Functions

subroutine sla_syamv (uplo, n, alpha, a, lda, x, incx, beta, y, incy)
 SLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds.
real function sla_syrcond (uplo, n, a, lda, af, ldaf, ipiv, cmode, c, info, work, iwork)
 SLA_SYRCOND estimates the Skeel condition number for a symmetric indefinite matrix.
subroutine sla_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)
 SLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric indefinite matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.
real function sla_syrpvgrw (uplo, n, info, a, lda, af, ldaf, ipiv, work)
 SLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite matrix.
subroutine slasyf (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 SLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
subroutine slasyf_aa (uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
 SLASYF_AA
subroutine slasyf_rook (uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
 SLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
subroutine ssycon (uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
 SSYCON
subroutine ssycon_rook (uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
  SSYCON_ROOK
subroutine ssyconv (uplo, way, n, a, lda, ipiv, e, info)
 SSYCONV
subroutine ssyequb (uplo, n, a, lda, s, scond, amax, work, info)
 SSYEQUB
subroutine ssygs2 (itype, uplo, n, a, lda, b, ldb, info)
 SSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm).
subroutine ssygst (itype, uplo, n, a, lda, b, ldb, info)
 SSYGST
subroutine ssyrfs (uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 SSYRFS
subroutine ssyrfsx (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)
 SSYRFSX
subroutine ssytd2 (uplo, n, a, lda, d, e, tau, info)
 SSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm).
subroutine ssytf2 (uplo, n, a, lda, ipiv, info)
 SSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).
subroutine ssytf2_rook (uplo, n, a, lda, ipiv, info)
 SSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm).
subroutine ssytrd (uplo, n, a, lda, d, e, tau, work, lwork, info)
 SSYTRD
subroutine ssytrd_2stage (vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
 SSYTRD_2STAGE
subroutine ssytrd_sy2sb (uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
 SSYTRD_SY2SB
subroutine ssytrf (uplo, n, a, lda, ipiv, work, lwork, info)
 SSYTRF
subroutine ssytrf_aa (uplo, n, a, lda, ipiv, work, lwork, info)
 SSYTRF_AA
subroutine ssytrf_aa_2stage (uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
 SSYTRF_AA_2STAGE
subroutine ssytrf_rook (uplo, n, a, lda, ipiv, work, lwork, info)
 SSYTRF_ROOK
subroutine ssytri (uplo, n, a, lda, ipiv, work, info)
 SSYTRI
subroutine ssytri2 (uplo, n, a, lda, ipiv, work, lwork, info)
 SSYTRI2
subroutine ssytri2x (uplo, n, a, lda, ipiv, work, nb, info)
 SSYTRI2X
subroutine ssytri_rook (uplo, n, a, lda, ipiv, work, info)
 SSYTRI_ROOK
subroutine ssytrs (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 SSYTRS
subroutine ssytrs2 (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
 SSYTRS2
subroutine ssytrs_aa (uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
 SSYTRS_AA
subroutine ssytrs_aa_2stage (uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
 SSYTRS_AA_2STAGE
subroutine ssytrs_rook (uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
 SSYTRS_ROOK
subroutine stgsyl (trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
 STGSYL
subroutine strsyl (trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
 STRSYL

Detailed Description

This is the group of real computational functions for SY matrices

Function Documentation

◆ sla_syamv()

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

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

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

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

Definition at line 175 of file sla_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 REAL ALPHA, BETA
184 INTEGER INCX, INCY, LDA, N, UPLO
185* ..
186* .. Array Arguments ..
187 REAL A( LDA, * ), X( * ), Y( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ONE, ZERO
194 parameter( one = 1.0e+0, zero = 0.0e+0 )
195* ..
196* .. Local Scalars ..
197 LOGICAL SYMB_ZERO
198 REAL TEMP, SAFE1
199 INTEGER I, INFO, IY, J, JX, KX, KY
200* ..
201* .. External Subroutines ..
202 EXTERNAL xerbla, slamch
203 REAL SLAMCH
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( 'SLA_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 = slamch( '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.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.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.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.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 SLA_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
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
max
#define max(a, b)
Definition macros.h:21

◆ sla_syrcond()

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

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

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

Purpose:
!>
!>    SLA_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 REAL 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 REAL array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by SSYTRF.
!>
[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 SSYTRF.
!>
[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 REAL 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 REAL 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 144 of file sla_syrcond.f.

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

◆ sla_syrfsx_extended()

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

SLA_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 SLA_SYRFSX_EXTENDED + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!>
!> SLA_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 SSYRFSX 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 REAL 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 REAL array, dimension (LDAF,N)
!>     The block diagonal matrix D and the multipliers used to
!>     obtain the factor U or L as computed by SSYTRF.
!>
[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 SSYTRF.
!>
[in]COLEQU
!>          COLEQU is LOGICAL
!>     If .TRUE. then column equilibration was done to A before calling
!>     this routine. This is needed to compute the solution and error
!>     bounds correctly.
!>
[in]C
!>          C is REAL array, dimension (N)
!>     The column scale factors for A. If COLEQU = .FALSE., C
!>     is not accessed. If C is input, each element of C should be a power
!>     of the radix to ensure a reliable solution and error estimates.
!>     Scaling by powers of the radix does not cause rounding errors unless
!>     the result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[in]B
!>          B is REAL 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 REAL array, dimension (LDY,NRHS)
!>     On entry, the solution matrix X, as computed by SSYTRS.
!>     On exit, the improved solution matrix Y.
!>
[in]LDY
!>          LDY is INTEGER
!>     The leading dimension of the array Y.  LDY >= max(1,N).
!>
[out]BERR_OUT
!>          BERR_OUT is REAL array, dimension (NRHS)
!>     On exit, BERR_OUT(j) contains the componentwise relative backward
!>     error for right-hand-side j from the formula
!>         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
!>     where abs(Z) is the componentwise absolute value of the matrix
!>     or vector Z. This is computed by SLA_LIN_BERR.
!>
[in]N_NORMS
!>          N_NORMS is INTEGER
!>     Determines which error bounds to return (see ERR_BNDS_NORM
!>     and ERR_BNDS_COMP).
!>     If N_NORMS >= 1 return normwise error bounds.
!>     If N_NORMS >= 2 return componentwise error bounds.
!>
[in,out]ERR_BNDS_NORM
!>          ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     This subroutine is only responsible for setting the second field
!>     above.
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in,out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     This subroutine is only responsible for setting the second field
!>     above.
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]RES
!>          RES is REAL array, dimension (N)
!>     Workspace to hold the intermediate residual.
!>
[in]AYB
!>          AYB is REAL array, dimension (N)
!>     Workspace. This can be the same workspace passed for Y_TAIL.
!>
[in]DY
!>          DY is REAL array, dimension (N)
!>     Workspace to hold the intermediate solution.
!>
[in]Y_TAIL
!>          Y_TAIL is REAL array, dimension (N)
!>     Workspace to hold the trailing bits of the intermediate solution.
!>
[in]RCOND
!>          RCOND is REAL
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[in]ITHRESH
!>          ITHRESH is INTEGER
!>     The maximum number of residual computations allowed for
!>     refinement. The default is 10. For 'aggressive' set to 100 to
!>     permit convergence using approximate factorizations or
!>     factorizations other than LU. If the factorization uses a
!>     technique other than Gaussian elimination, the guarantees in
!>     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.
!>
[in]RTHRESH
!>          RTHRESH is REAL
!>     Determines when to stop refinement if the error estimate stops
!>     decreasing. Refinement will stop when the next solution no longer
!>     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is
!>     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The
!>     default value is 0.5. For 'aggressive' set to 0.9 to permit
!>     convergence on extremely ill-conditioned matrices. See LAWN 165
!>     for more details.
!>
[in]DZ_UB
!>          DZ_UB is REAL
!>     Determines when to start considering componentwise convergence.
!>     Componentwise convergence is only considered after each component
!>     of the solution Y is stable, which we define as the relative
!>     change in each component being less than DZ_UB. The default value
!>     is 0.25, requiring the first bit to be stable. See LAWN 165 for
!>     more details.
!>
[in]IGNORE_CWISE
!>          IGNORE_CWISE is LOGICAL
!>     If .TRUE. then ignore componentwise convergence. Default value
!>     is .FALSE..
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>       < 0:  if INFO = -i, the ith argument to SLA_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 sla_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 REAL RTHRESH, DZ_UB
407* ..
408* .. Array Arguments ..
409 INTEGER IPIV( * )
410 REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
411 $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * )
412 REAL 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 REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
422 $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,
423 $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,
424 $ EPS, HUGEVAL, INCR_THRESH
425 LOGICAL INCR_PREC, UPPER
426* ..
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 saxpy, scopy, ssytrs, ssymv, blas_ssymv_x,
460 $ blas_ssymv2_x, sla_syamv, sla_wwaddw,
461 $ sla_lin_berr
462 REAL SLAMCH
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( 'SLA_SYRFSX_EXTENDED', -info )
488 RETURN
489 END IF
490 eps = slamch( 'Epsilon' )
491 hugeval = slamch( 'Overflow' )
492* Force HUGEVAL to Inf
493 hugeval = hugeval * hugeval
494* Using HUGEVAL may lead to spurious underflows.
495 incr_thresh = real( 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.0
508 END DO
509 END IF
510
511 dxrat = 0.0
512 dxratmax = 0.0
513 dzrat = 0.0
514 dzratmax = 0.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 scopy( n, b( 1, j ), 1, res, 1 )
532 IF (y_prec_state .EQ. base_residual) THEN
533 CALL ssymv( uplo, n, -1.0, a, lda, y(1,j), 1,
534 $ 1.0, res, 1 )
535 ELSE IF (y_prec_state .EQ. extra_residual) THEN
536 CALL blas_ssymv_x( uplo2, n, -1.0, a, lda,
537 $ y( 1, j ), 1, 1.0, res, 1, prec_type )
538 ELSE
539 CALL blas_ssymv2_x(uplo2, n, -1.0, a, lda,
540 $ y(1, j), y_tail, 1, 1.0, res, 1, prec_type)
541 END IF
542
543! XXX: RES is no longer needed.
544 CALL scopy( n, res, 1, dy, 1 )
545 CALL ssytrs( 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.0
550 normy = 0.0
551 normdx = 0.0
552 dz_z = 0.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.0 ) THEN
560 dz_z = max( dz_z, dyk / yk )
561 ELSE IF ( dyk .NE. 0.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.0 ) THEN
579 dx_x = normdx / normx
580 ELSE IF ( normdx .EQ. 0.0 ) THEN
581 dx_x = 0.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.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.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 saxpy( n, 1.0, dy, 1, y(1,j), 1 )
654 ELSE
655 CALL sla_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 scopy( n, b( 1, j ), 1, res, 1 )
686 CALL ssymv( uplo, n, -1.0, a, lda, y(1,j), 1, 1.0, res, 1 )
687
688 DO i = 1, n
689 ayb( i ) = abs( b( i, j ) )
690 END DO
691*
692* Compute abs(op(A_s))*abs(Y) + abs(B_s).
693*
694 CALL sla_syamv( uplo2, n, 1.0,
695 $ a, lda, y(1, j), 1, 1.0, ayb, 1 )
696
697 CALL sla_lin_berr( n, n, 1, res, ayb, berr_out( j ) )
698*
699* End of loop for each RHS.
700*
701 END DO
702*
703 RETURN
704*
705* End of SLA_SYRFSX_EXTENDED
706*
sla_lin_berr
subroutine sla_lin_berr(n, nz, nrhs, res, ayb, berr)
SLA_LIN_BERR computes a component-wise relative backward error.
Definition sla_lin_berr.f:101
sla_wwaddw
subroutine sla_wwaddw(n, x, y, w)
SLA_WWADDW adds a vector into a doubled-single vector.
Definition sla_wwaddw.f:81
sla_syamv
subroutine sla_syamv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
SLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bou...
Definition sla_syamv.f:177
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89
ssymv
subroutine ssymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
SSYMV
Definition ssymv.f:152
min
#define min(a, b)
Definition macros.h:20

◆ sla_syrpvgrw()

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

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

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

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

Definition at line 120 of file sla_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 REAL A( LDA, * ), AF( LDAF, * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* .. Local Scalars ..
139 INTEGER NCOLS, I, J, K, KP
140 REAL 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.0
164 DO i = 1, 2*n
165 work( i ) = 0.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 ssytrs.
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.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.0 ) THEN
311 rpvgrw = min( amax / umax, rpvgrw )
312 END IF
313 END DO
314 END IF
315
316 sla_syrpvgrw = rpvgrw
317*
318* End of SLA_SYRPVGRW
319*
sla_syrpvgrw
real function sla_syrpvgrw(uplo, n, info, a, lda, af, ldaf, ipiv, work)
SLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefinite m...
Definition sla_syrpvgrw.f:122

◆ slasyf()

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

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

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

Purpose:
!>
!> SLASYF 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.
!>
!> SLASYF is an auxiliary routine called by SSYTRF. 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 REAL 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 REAL 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 slasyf.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 REAL A( LDA, * ), W( LDW, * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ZERO, ONE
194 parameter( zero = 0.0e+0, one = 1.0e+0 )
195 REAL EIGHT, SEVTEN
196 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
197* ..
198* .. Local Scalars ..
199 INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
200 $ KSTEP, KW
201 REAL ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
202 $ ROWMAX, T
203* ..
204* .. External Functions ..
205 LOGICAL LSAME
206 INTEGER ISAMAX
207 EXTERNAL lsame, isamax
208* ..
209* .. External Subroutines ..
210 EXTERNAL scopy, sgemm, sgemv, sscal, sswap
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 scopy( k, a( 1, k ), 1, w( 1, kw ), 1 )
245 IF( k.LT.n )
246 $ CALL sgemv( '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 = isamax( 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 scopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 )
285 CALL scopy( k-imax, a( imax, imax+1 ), lda,
286 $ w( imax+1, kw-1 ), 1 )
287 IF( k.LT.n )
288 $ CALL sgemv( '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 + isamax( k-imax, w( imax+1, kw-1 ), 1 )
296 rowmax = abs( w( jmax, kw-1 ) )
297 IF( imax.GT.1 ) THEN
298 jmax = isamax( 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 scopy( 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 scopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
349 $ lda )
350 IF( kp.GT.1 )
351 $ CALL scopy( 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 sswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
360 $ lda )
361 CALL sswap( 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 scopy( k, w( 1, kw ), 1, a( 1, k ), 1 )
381 r1 = one / a( k, k )
382 CALL sscal( 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 sgemv( '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 sgemm( '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 sswap( 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 scopy( n-k+1, a( k, k ), 1, w( k, k ), 1 )
542 CALL sgemv( '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 + isamax( 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 scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 )
581 CALL scopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),
582 $ 1 )
583 CALL sgemv( '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 + isamax( imax-k, w( k, k+1 ), 1 )
590 rowmax = abs( w( jmax, k+1 ) )
591 IF( imax.LT.n ) THEN
592 jmax = imax + isamax( 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 scopy( 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 scopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
639 $ lda )
640 IF( kp.LT.n )
641 $ CALL scopy( 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 sswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
650 CALL sswap( 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 scopy( 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 sscal( 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 sgemv( '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 sgemm( '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 sswap( 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 SLASYF
818*
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
sswap
subroutine sswap(n, sx, incx, sy, incy)
SSWAP
Definition sswap.f:82
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ slasyf_aa()

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

SLASYF_AA

Download SLASYF_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 SSYTRF_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 REAL 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 REAL workspace, dimension (LDH,NB).
!>
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the workspace H. LDH >= max(1,M).
!>
[out]WORK
!>          WORK is REAL workspace, dimension (M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file slasyf_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 REAL A( LDA, * ), H( LDH, * ), WORK( * )
158* ..
159*
160* =====================================================================
161* .. Parameters ..
162 REAL ZERO, ONE
163 parameter( zero = 0.0e+0, one = 1.0e+0 )
164*
165* .. Local Scalars ..
166 INTEGER J, K, K1, I1, I2, MJ
167 REAL PIV, ALPHA
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER ISAMAX, ILAENV
172 EXTERNAL lsame, ilaenv, isamax
173* ..
174* .. External Subroutines ..
175 EXTERNAL saxpy, sgemv, sscal, scopy, sswap, slaset,
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 SSYTRF_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 sgemv( '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 scopy( 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 saxpy( 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 saxpy( 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 = isamax( 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 sswap( 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 sswap( 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 sswap( 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 sswap( 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 scopy( 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 scopy( m-j-1, work( 3 ), 1, a( k, j+2 ), lda )
330 CALL sscal( m-j-1, alpha, a( k, j+2 ), lda )
331 ELSE
332 CALL slaset( '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 SSYTRF_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 sgemv( '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 scopy( 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 saxpy( 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 saxpy( 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 = isamax( 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 sswap( 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 sswap( 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 sswap( 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 sswap( 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 scopy( 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 scopy( m-j-1, work( 3 ), 1, a( j+2, k ), 1 )
481 CALL sscal( m-j-1, alpha, a( j+2, k ), 1 )
482 ELSE
483 CALL slaset( '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 SLASYF_AA
495*
slaset
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition slaset.f:110
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162

◆ slasyf_rook()

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

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

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

Purpose:
!>
!> SLASYF_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.
!>
!> SLASYF_ROOK is an auxiliary routine called by SSYTRF_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 REAL 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 REAL 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 slasyf_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 REAL A( LDA, * ), W( LDW, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 REAL ZERO, ONE
202 parameter( zero = 0.0e+0, one = 1.0e+0 )
203 REAL EIGHT, SEVTEN
204 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
205* ..
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 REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
212 $ STEMP, R1, ROWMAX, T, SFMIN
213* ..
214* .. External Functions ..
215 LOGICAL LSAME
216 INTEGER ISAMAX
217 REAL SLAMCH
218 EXTERNAL lsame, isamax, slamch
219* ..
220* .. External Subroutines ..
221 EXTERNAL scopy, sgemm, sgemv, sscal, sswap
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 = slamch( '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 scopy( k, a( 1, k ), 1, w( 1, kw ), 1 )
264 IF( k.LT.n )
265 $ CALL sgemv( '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 = isamax( 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 scopy( 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 scopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 )
321 CALL scopy( k-imax, a( imax, imax+1 ), lda,
322 $ w( imax+1, kw-1 ), 1 )
323*
324 IF( k.LT.n )
325 $ CALL sgemv( '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 + isamax( 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 = isamax( imax-1, w( 1, kw-1 ), 1 )
343 stemp = abs( w( itemp, kw-1 ) )
344 IF( stemp.GT.rowmax ) THEN
345 rowmax = stemp
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 scopy( 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 scopy( 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 scopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda )
413 CALL scopy( 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 sswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
419 CALL sswap( 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 scopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),
430 $ lda )
431 CALL scopy( 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 sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
437 CALL sswap( 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 scopy( 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 sscal( 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 sgemv( '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 sgemm( '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 sswap( 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 sswap( 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 scopy( n-k+1, a( k, k ), 1, w( k, k ), 1 )
590 IF( k.GT.1 )
591 $ CALL sgemv( '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 + isamax( 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 scopy( 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 scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1)
647 CALL scopy( n-imax+1, a( imax, imax ), 1,
648 $ w( imax, k+1 ), 1 )
649 IF( k.GT.1 )
650 $ CALL sgemv( '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 + isamax( 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 + isamax( n-imax, w( imax+1, k+1 ), 1)
667 stemp = abs( w( itemp, k+1 ) )
668 IF( stemp.GT.rowmax ) THEN
669 rowmax = stemp
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 scopy( 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 scopy( 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 scopy( p-k, a( k, k ), 1, a( p, k ), lda )
733 CALL scopy( 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 sswap( k, a( k, 1 ), lda, a( p, 1 ), lda )
739 CALL sswap( 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 scopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda )
750 CALL scopy( 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 sswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda )
755 CALL sswap( 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 scopy( 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 sscal( 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 sgemv( '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 sgemm( '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 sswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda )
874 jj = j + 1
875 IF( jp1.NE.jj .AND. kstep.EQ.2 )
876 $ CALL sswap( 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 SLASYF_ROOK
888*

◆ ssycon()

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

SSYCON

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

Purpose:
!>
!> SSYCON 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 SSYTRF.
!>
!> 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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF.
!>
[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 SSYTRF.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is REAL 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 ssycon.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 REAL ANORM, RCOND
139* ..
140* .. Array Arguments ..
141 INTEGER IPIV( * ), IWORK( * )
142 REAL A( LDA, * ), WORK( * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 REAL ONE, ZERO
149 parameter( one = 1.0e+0, zero = 0.0e+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL UPPER
153 INTEGER I, KASE
154 REAL 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 slacn2, ssytrs, 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( 'SSYCON', -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 slacn2( 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 ssytrs( 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 SSYCON
240*

◆ ssycon_rook()

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

SSYCON_ROOK

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

Purpose:
!>
!> SSYCON_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 SSYTRF_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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF_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 SSYTRF_ROOK.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is REAL 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:
!>
!>   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 142 of file ssycon_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 REAL ANORM, RCOND
153* ..
154* .. Array Arguments ..
155 INTEGER IPIV( * ), IWORK( * )
156 REAL A( LDA, * ), WORK( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ONE, ZERO
163 parameter( one = 1.0e+0, zero = 0.0e+0 )
164* ..
165* .. Local Scalars ..
166 LOGICAL UPPER
167 INTEGER I, KASE
168 REAL 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 slacn2, ssytrs_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( 'SSYCON_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 slacn2( 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 ssytrs_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 SSYCON_ROOK
254*
ssytrs_rook
subroutine ssytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
SSYTRS_ROOK
Definition ssytrs_rook.f:136

◆ ssyconv()

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

SSYCONV

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

Purpose:
!>
!> SSYCONV 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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF.
!>
[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 SSYTRF.
!>
[out]E
!>          E is REAL 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 ssyconv.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 REAL A( LDA, * ), E( * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 REAL ZERO
132 parameter( zero = 0.0e+0 )
133* ..
134* .. External Functions ..
135 LOGICAL LSAME
136 EXTERNAL lsame
137*
138* .. External Subroutines ..
139 EXTERNAL xerbla
140* .. Local Scalars ..
141 LOGICAL UPPER, CONVERT
142 INTEGER I, IP, J
143 REAL 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( 'SSYCONV', -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 SSYCONV
362*

◆ ssyequb()

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

SSYEQUB

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

Purpose:
!>
!> SSYEQUB 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 REAL array, dimension (LDA,N)
!>          The N-by-N symmetric matrix whose scaling factors are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[out]S
!>          S is REAL array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is REAL
!>          If INFO = 0, S contains the ratio of the smallest S(i) to
!>          the largest S(i). If SCOND >= 0.1 and AMAX is neither too
!>          large nor too small, it is not worth scaling by S.
!>
[out]AMAX
!>          AMAX is REAL
!>          Largest absolute value of any matrix element. If AMAX is
!>          very close to overflow or very close to underflow, the
!>          matrix should be scaled.
!>
[out]WORK
!>          WORK is REAL 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 ssyequb.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 REAL AMAX, SCOND
139 CHARACTER UPLO
140* ..
141* .. Array Arguments ..
142 REAL A( LDA, * ), S( * ), WORK( * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 REAL ONE, ZERO
149 parameter( one = 1.0e0, zero = 0.0e0 )
150 INTEGER MAX_ITER
151 parameter( max_iter = 100 )
152* ..
153* .. Local Scalars ..
154 INTEGER I, J, ITER
155 REAL 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 REAL SLAMCH
161 LOGICAL LSAME
162 EXTERNAL lsame, slamch
163* ..
164* .. External Subroutines ..
165 EXTERNAL slassq, 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( 'SSYEQUB', -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.0e0 / s( j )
225 END DO
226
227 tol = one / sqrt( 2.0e0 * n )
228
229 DO iter = 1, max_iter
230 scale = 0.0e0
231 sumsq = 0.0e0
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.0e0
256 DO i = 1, n
257 avg = avg + s( i )*work( i )
258 END DO
259 avg = avg / n
260
261 std = 0.0e0
262 DO i = n+1, 2*n
263 work( i ) = s( i-n ) * work( i-n ) - avg
264 END DO
265 CALL slassq( 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 = slamch( 'SAFEMIN' )
318 bignum = one / smlnum
319 smin = bignum
320 smax = zero
321 t = one / sqrt( avg )
322 base = slamch( '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*
slassq
subroutine slassq(n, x, incx, scl, sumsq)
SLASSQ updates a sum of squares represented in scaled form.
Definition slassq.f90:137

◆ ssygs2()

subroutine ssygs2 ( integer itype,
character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldb, * ) b,
integer ldb,
integer info )

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

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

Purpose:
!>
!> SSYGS2 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 SPOTRF.
!>
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 REAL 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 REAL array, dimension (LDB,N)
!>          The triangular factor from the Cholesky factorization of B,
!>          as returned by SPOTRF.
!>
[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 ssygs2.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 REAL A( LDA, * ), B( LDB, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ONE, HALF
144 parameter( one = 1.0, half = 0.5 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER K
149 REAL AKK, BKK, CT
150* ..
151* .. External Subroutines ..
152 EXTERNAL saxpy, sscal, ssyr2, strmv, strsv, 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( 'SSYGS2', -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 sscal( n-k, one / bkk, a( k, k+1 ), lda )
198 ct = -half*akk
199 CALL saxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ),
200 $ lda )
201 CALL ssyr2( uplo, n-k, -one, a( k, k+1 ), lda,
202 $ b( k, k+1 ), ldb, a( k+1, k+1 ), lda )
203 CALL saxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ),
204 $ lda )
205 CALL strsv( 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 sscal( n-k, one / bkk, a( k+1, k ), 1 )
223 ct = -half*akk
224 CALL saxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 )
225 CALL ssyr2( uplo, n-k, -one, a( k+1, k ), 1,
226 $ b( k+1, k ), 1, a( k+1, k+1 ), lda )
227 CALL saxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 )
228 CALL strsv( 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 strmv( uplo, 'No transpose', 'Non-unit', k-1, b,
245 $ ldb, a( 1, k ), 1 )
246 ct = half*akk
247 CALL saxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 )
248 CALL ssyr2( uplo, k-1, one, a( 1, k ), 1, b( 1, k ), 1,
249 $ a, lda )
250 CALL saxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 )
251 CALL sscal( 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 strmv( uplo, 'Transpose', 'Non-unit', k-1, b, ldb,
265 $ a( k, 1 ), lda )
266 ct = half*akk
267 CALL saxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda )
268 CALL ssyr2( uplo, k-1, one, a( k, 1 ), lda, b( k, 1 ),
269 $ ldb, a, lda )
270 CALL saxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda )
271 CALL sscal( 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 SSYGS2
279*
ssyr2
subroutine ssyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
SSYR2
Definition ssyr2.f:147
strmv
subroutine strmv(uplo, trans, diag, n, a, lda, x, incx)
STRMV
Definition strmv.f:147
strsv
subroutine strsv(uplo, trans, diag, n, a, lda, x, incx)
STRSV
Definition strsv.f:149

◆ ssygst()

subroutine ssygst ( integer itype,
character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldb, * ) b,
integer ldb,
integer info )

SSYGST

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

Purpose:
!>
!> SSYGST 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 SPOTRF.
!>
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 REAL 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 REAL array, dimension (LDB,N)
!>          The triangular factor from the Cholesky factorization of B,
!>          as returned by SPOTRF.
!>
[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 ssygst.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 REAL A( LDA, * ), B( LDB, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ONE, HALF
144 parameter( one = 1.0, half = 0.5 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER K, KB, NB
149* ..
150* .. External Subroutines ..
151 EXTERNAL ssygs2, ssymm, ssyr2k, strmm, strsm, 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( 'SSYGST', -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, 'SSYGST', uplo, n, -1, -1, -1 )
191*
192 IF( nb.LE.1 .OR. nb.GE.n ) THEN
193*
194* Use unblocked code
195*
196 CALL ssygs2( 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 ssygs2( itype, uplo, kb, a( k, k ), lda,
212 $ b( k, k ), ldb, info )
213 IF( k+kb.LE.n ) THEN
214 CALL strsm( 'Left', uplo, 'Transpose', 'Non-unit',
215 $ kb, n-k-kb+1, one, b( k, k ), ldb,
216 $ a( k, k+kb ), lda )
217 CALL ssymm( '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 ssyr2k( 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 ssymm( '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 strsm( '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 ssygs2( itype, uplo, kb, a( k, k ), lda,
242 $ b( k, k ), ldb, info )
243 IF( k+kb.LE.n ) THEN
244 CALL strsm( 'Right', uplo, 'Transpose', 'Non-unit',
245 $ n-k-kb+1, kb, one, b( k, k ), ldb,
246 $ a( k+kb, k ), lda )
247 CALL ssymm( '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 ssyr2k( 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 ssymm( '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 strsm( '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 strmm( 'Left', uplo, 'No transpose', 'Non-unit',
274 $ k-1, kb, one, b, ldb, a( 1, k ), lda )
275 CALL ssymm( 'Right', uplo, k-1, kb, half, a( k, k ),
276 $ lda, b( 1, k ), ldb, one, a( 1, k ), lda )
277 CALL ssyr2k( uplo, 'No transpose', k-1, kb, one,
278 $ a( 1, k ), lda, b( 1, k ), ldb, one, a,
279 $ lda )
280 CALL ssymm( 'Right', uplo, k-1, kb, half, a( k, k ),
281 $ lda, b( 1, k ), ldb, one, a( 1, k ), lda )
282 CALL strmm( 'Right', uplo, 'Transpose', 'Non-unit',
283 $ k-1, kb, one, b( k, k ), ldb, a( 1, k ),
284 $ lda )
285 CALL ssygs2( 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 strmm( 'Right', uplo, 'No transpose', 'Non-unit',
298 $ kb, k-1, one, b, ldb, a( k, 1 ), lda )
299 CALL ssymm( 'Left', uplo, kb, k-1, half, a( k, k ),
300 $ lda, b( k, 1 ), ldb, one, a( k, 1 ), lda )
301 CALL ssyr2k( uplo, 'Transpose', k-1, kb, one,
302 $ a( k, 1 ), lda, b( k, 1 ), ldb, one, a,
303 $ lda )
304 CALL ssymm( 'Left', uplo, kb, k-1, half, a( k, k ),
305 $ lda, b( k, 1 ), ldb, one, a( k, 1 ), lda )
306 CALL strmm( 'Left', uplo, 'Transpose', 'Non-unit', kb,
307 $ k-1, one, b( k, k ), ldb, a( k, 1 ), lda )
308 CALL ssygs2( 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 SSYGST
317*
ssygs2
subroutine ssygs2(itype, uplo, n, a, lda, b, ldb, info)
SSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorizatio...
Definition ssygs2.f:127
ssymm
subroutine ssymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
SSYMM
Definition ssymm.f:189
strsm
subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRSM
Definition strsm.f:181
ssyr2k
subroutine ssyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SSYR2K
Definition ssyr2k.f:192
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ ssyrfs()

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

SSYRFS

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

Purpose:
!>
!> SSYRFS 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 REAL 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 REAL 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 SSYTRF.
!>
[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 SSYTRF.
!>
[in]B
!>          B is REAL 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 REAL array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by SSYTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is REAL array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is REAL array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is REAL 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 ssyrfs.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 REAL 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 REAL ZERO
212 parameter( zero = 0.0e+0 )
213 REAL ONE
214 parameter( one = 1.0e+0 )
215 REAL TWO
216 parameter( two = 2.0e+0 )
217 REAL THREE
218 parameter( three = 3.0e+0 )
219* ..
220* .. Local Scalars ..
221 LOGICAL UPPER
222 INTEGER COUNT, I, J, K, KASE, NZ
223 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
224* ..
225* .. Local Arrays ..
226 INTEGER ISAVE( 3 )
227* ..
228* .. External Subroutines ..
229 EXTERNAL saxpy, scopy, slacn2, ssymv, ssytrs, xerbla
230* ..
231* .. Intrinsic Functions ..
232 INTRINSIC abs, max
233* ..
234* .. External Functions ..
235 LOGICAL LSAME
236 REAL SLAMCH
237 EXTERNAL lsame, slamch
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( 'SSYRFS', -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 = slamch( 'Epsilon' )
279 safmin = slamch( '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 scopy( n, b( 1, j ), 1, work( n+1 ), 1 )
296 CALL ssymv( 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 ssytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,
359 $ info )
360 CALL saxpy( 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 SLACN2 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 slacn2( 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 ssytrs( 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 ssytrs( 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 SSYRFS
437*

◆ ssyrfsx()

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

SSYRFSX

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

Purpose:
!>
!>    SSYRFSX 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 REAL 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 REAL 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 SSYTRF.
!>
[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 SSYTRF.
!>
[in,out]S
!>          S is REAL array, dimension (N)
!>     The scale factors for A.  If EQUED = 'Y', A is multiplied on
!>     the left and right by diag(S).  S is an input argument if FACT =
!>     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED
!>     = 'Y', each element of S must be positive.  If S is output, each
!>     element of S is a power of the radix. If S is input, each element
!>     of S should be a power of the radix to ensure a reliable solution
!>     and error estimates. Scaling by powers of the radix does not cause
!>     rounding errors unless the result underflows or overflows.
!>     Rounding errors during scaling lead to refining with a matrix that
!>     is not equivalent to the input matrix, producing error estimates
!>     that may not be reliable.
!>
[in]B
!>          B is REAL 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 REAL array, dimension (LDX,NRHS)
!>     On entry, the solution matrix X, as computed by SGETRS.
!>     On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>     The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]RCOND
!>          RCOND is REAL
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[out]BERR
!>          BERR is REAL array, dimension (NRHS)
!>     Componentwise relative backward error.  This is the
!>     componentwise relative backward error of each solution vector X(j)
!>     (i.e., the smallest relative change in any element of A or B that
!>     makes X(j) an exact solution).
!>
[in]N_ERR_BNDS
!>          N_ERR_BNDS is INTEGER
!>     Number of error bounds to return for each right hand side
!>     and each type (normwise or componentwise).  See ERR_BNDS_NORM and
!>     ERR_BNDS_COMP below.
!>
[out]ERR_BNDS_NORM
!>          ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]NPARAMS
!>          NPARAMS is INTEGER
!>     Specifies the number of parameters set in PARAMS.  If <= 0, the
!>     PARAMS array is never referenced and default values are used.
!>
[in,out]PARAMS
!>          PARAMS is REAL array, dimension NPARAMS
!>     Specifies algorithm parameters.  If an entry is < 0.0, then
!>     that entry will be filled with default value used for that
!>     parameter.  Only positions up to NPARAMS are accessed; defaults
!>     are used for higher-numbered parameters.
!>
!>       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
!>            refinement or not.
!>         Default: 1.0
!>            = 0.0:  No refinement is performed, and no error bounds are
!>                    computed.
!>            = 1.0:  Use the double-precision refinement algorithm,
!>                    possibly with doubled-single computations if the
!>                    compilation environment does not support DOUBLE
!>                    PRECISION.
!>              (other values are reserved for future use)
!>
!>       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
!>            computations allowed for refinement.
!>         Default: 10
!>         Aggressive: Set to 100 to permit convergence using approximate
!>                     factorizations or factorizations other than LU. If
!>                     the factorization uses a technique other than
!>                     Gaussian elimination, the guarantees in
!>                     err_bnds_norm and err_bnds_comp may no longer be
!>                     trustworthy.
!>
!>       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
!>            will attempt to find a solution with small componentwise
!>            relative error in the double-precision algorithm.  Positive
!>            is true, 0.0 is false.
!>         Default: 1.0 (attempt componentwise convergence)
!>
[out]WORK
!>          WORK is REAL 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 ssyrfsx.f.

402*
403* -- LAPACK computational routine --
404* -- LAPACK is a software package provided by Univ. of Tennessee, --
405* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
406*
407* .. Scalar Arguments ..
408 CHARACTER UPLO, EQUED
409 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
410 $ N_ERR_BNDS
411 REAL RCOND
412* ..
413* .. Array Arguments ..
414 INTEGER IPIV( * ), IWORK( * )
415 REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
416 $ X( LDX, * ), WORK( * )
417 REAL S( * ), PARAMS( * ), BERR( * ),
418 $ ERR_BNDS_NORM( NRHS, * ),
419 $ ERR_BNDS_COMP( NRHS, * )
420* ..
421*
422* ==================================================================
423*
424* .. Parameters ..
425 REAL ZERO, ONE
426 parameter( zero = 0.0e+0, one = 1.0e+0 )
427 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
428 $ COMPONENTWISE_DEFAULT
429 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
430 parameter( itref_default = 1.0 )
431 parameter( ithresh_default = 10.0 )
432 parameter( componentwise_default = 1.0 )
433 parameter( rthresh_default = 0.5 )
434 parameter( dzthresh_default = 0.25 )
435 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
436 $ LA_LINRX_CWISE_I
437 parameter( la_linrx_itref_i = 1,
438 $ la_linrx_ithresh_i = 2 )
439 parameter( la_linrx_cwise_i = 3 )
440 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
441 $ LA_LINRX_RCOND_I
442 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
443 parameter( la_linrx_rcond_i = 3 )
444* ..
445* .. Local Scalars ..
446 CHARACTER(1) NORM
447 LOGICAL RCEQU
448 INTEGER J, PREC_TYPE, REF_TYPE, N_NORMS
449 REAL ANORM, RCOND_TMP
450 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
451 LOGICAL IGNORE_CWISE
452 INTEGER ITHRESH
453 REAL RTHRESH, UNSTABLE_THRESH
454* ..
455* .. External Subroutines ..
456 EXTERNAL xerbla, ssycon, sla_syrfsx_extended
457* ..
458* .. Intrinsic Functions ..
459 INTRINSIC max, sqrt
460* ..
461* .. External Functions ..
462 EXTERNAL lsame, ilaprec
463 EXTERNAL slamch, slansy, sla_syrcond
464 REAL SLAMCH, SLANSY, SLA_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.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 = real( n )*slamch( 'Epsilon' )
485 ithresh = int( ithresh_default )
486 rthresh = rthresh_default
487 unstable_thresh = dzthresh_default
488 ignore_cwise = componentwise_default .EQ. 0.0
489*
490 IF ( nparams.GE.la_linrx_ithresh_i ) THEN
491 IF ( params( la_linrx_ithresh_i ).LT.0.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.0 ) THEN
499 IF ( ignore_cwise ) THEN
500 params( la_linrx_cwise_i ) = 0.0
501 ELSE
502 params( la_linrx_cwise_i ) = 1.0
503 END IF
504 ELSE
505 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.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( 'SSYRFSX', -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.0
546 DO j = 1, nrhs
547 berr( j ) = 0.0
548 IF ( n_err_bnds .GE. 1 ) THEN
549 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
550 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
551 END IF
552 IF ( n_err_bnds .GE. 2 ) THEN
553 err_bnds_norm( j, la_linrx_err_i ) = 0.0
554 err_bnds_comp( j, la_linrx_err_i ) = 0.0
555 END IF
556 IF ( n_err_bnds .GE. 3 ) THEN
557 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
558 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
559 END IF
560 END DO
561 RETURN
562 END IF
563*
564* Default to failure.
565*
566 rcond = 0.0
567 DO j = 1, nrhs
568 berr( j ) = 1.0
569 IF ( n_err_bnds .GE. 1 ) THEN
570 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
571 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
572 END IF
573 IF ( n_err_bnds .GE. 2 ) THEN
574 err_bnds_norm( j, la_linrx_err_i ) = 1.0
575 err_bnds_comp( j, la_linrx_err_i ) = 1.0
576 END IF
577 IF ( n_err_bnds .GE. 3 ) THEN
578 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
579 err_bnds_comp( j, la_linrx_rcond_i ) = 0.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 = slansy( norm, uplo, n, a, lda, work )
588 CALL ssycon( 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( 'D' )
596
597 CALL sla_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.0, sqrt( real( n ) ) )*slamch( '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 = sla_syrcond( uplo, n, a, lda, af, ldaf, ipiv,
612 $ -1, s, info, work, iwork )
613 ELSE
614 rcond_tmp = sla_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.0)
623 $ err_bnds_norm( j, la_linrx_err_i ) = 1.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.0
629 err_bnds_norm( j, la_linrx_trust_i ) = 0.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.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( slamch( 'Epsilon' ) )
656 DO j = 1, nrhs
657 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
658 $ THEN
659 rcond_tmp = sla_syrcond( uplo, n, a, lda, af, ldaf, ipiv,
660 $ 1, x(1,j), info, work, iwork )
661 ELSE
662 rcond_tmp = 0.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.0 )
669 $ err_bnds_comp( j, la_linrx_err_i ) = 1.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.0
675 err_bnds_comp( j, la_linrx_trust_i ) = 0.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.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 SSYRFSX
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
slansy
real function slansy(norm, uplo, n, a, lda, work)
SLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slansy.f:122
ssycon
subroutine ssycon(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
SSYCON
Definition ssycon.f:130
sla_syrfsx_extended
subroutine sla_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)
SLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric inde...
Definition sla_syrfsx_extended.f:396

◆ ssytd2()

subroutine ssytd2 ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( * ) tau,
integer info )

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

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

Purpose:
!>
!> SSYTD2 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 REAL 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 REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL 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 REAL 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 ssytd2.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 REAL A( LDA, * ), D( * ), E( * ), TAU( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ONE, ZERO, HALF
190 parameter( one = 1.0, zero = 0.0, half = 1.0 / 2.0 )
191* ..
192* .. Local Scalars ..
193 LOGICAL UPPER
194 INTEGER I
195 REAL ALPHA, TAUI
196* ..
197* .. External Subroutines ..
198 EXTERNAL saxpy, slarfg, ssymv, ssyr2, xerbla
199* ..
200* .. External Functions ..
201 LOGICAL LSAME
202 REAL SDOT
203 EXTERNAL lsame, sdot
204* ..
205* .. Intrinsic Functions ..
206 INTRINSIC max, min
207* ..
208* .. Executable Statements ..
209*
210* Test the input parameters
211*
212 info = 0
213 upper = lsame( uplo, 'U' )
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 END IF
221 IF( info.NE.0 ) THEN
222 CALL xerbla( 'SSYTD2', -info )
223 RETURN
224 END IF
225*
226* Quick return if possible
227*
228 IF( n.LE.0 )
229 $ RETURN
230*
231 IF( upper ) THEN
232*
233* Reduce the upper triangle of A
234*
235 DO 10 i = n - 1, 1, -1
236*
237* Generate elementary reflector H(i) = I - tau * v * v**T
238* to annihilate A(1:i-1,i+1)
239*
240 CALL slarfg( i, a( i, i+1 ), a( 1, i+1 ), 1, taui )
241 e( i ) = a( i, i+1 )
242*
243 IF( taui.NE.zero ) THEN
244*
245* Apply H(i) from both sides to A(1:i,1:i)
246*
247 a( i, i+1 ) = one
248*
249* Compute x := tau * A * v storing x in TAU(1:i)
250*
251 CALL ssymv( uplo, i, taui, a, lda, a( 1, i+1 ), 1, zero,
252 $ tau, 1 )
253*
254* Compute w := x - 1/2 * tau * (x**T * v) * v
255*
256 alpha = -half*taui*sdot( i, tau, 1, a( 1, i+1 ), 1 )
257 CALL saxpy( i, alpha, a( 1, i+1 ), 1, tau, 1 )
258*
259* Apply the transformation as a rank-2 update:
260* A := A - v * w**T - w * v**T
261*
262 CALL ssyr2( uplo, i, -one, a( 1, i+1 ), 1, tau, 1, a,
263 $ lda )
264*
265 a( i, i+1 ) = e( i )
266 END IF
267 d( i+1 ) = a( i+1, i+1 )
268 tau( i ) = taui
269 10 CONTINUE
270 d( 1 ) = a( 1, 1 )
271 ELSE
272*
273* Reduce the lower triangle of A
274*
275 DO 20 i = 1, n - 1
276*
277* Generate elementary reflector H(i) = I - tau * v * v**T
278* to annihilate A(i+2:n,i)
279*
280 CALL slarfg( n-i, a( i+1, i ), a( min( i+2, n ), i ), 1,
281 $ taui )
282 e( i ) = a( i+1, i )
283*
284 IF( taui.NE.zero ) THEN
285*
286* Apply H(i) from both sides to A(i+1:n,i+1:n)
287*
288 a( i+1, i ) = one
289*
290* Compute x := tau * A * v storing y in TAU(i:n-1)
291*
292 CALL ssymv( uplo, n-i, taui, a( i+1, i+1 ), lda,
293 $ a( i+1, i ), 1, zero, tau( i ), 1 )
294*
295* Compute w := x - 1/2 * tau * (x**T * v) * v
296*
297 alpha = -half*taui*sdot( n-i, tau( i ), 1, a( i+1, i ),
298 $ 1 )
299 CALL saxpy( n-i, alpha, a( i+1, i ), 1, tau( i ), 1 )
300*
301* Apply the transformation as a rank-2 update:
302* A := A - v * w**T - w * v**T
303*
304 CALL ssyr2( uplo, n-i, -one, a( i+1, i ), 1, tau( i ), 1,
305 $ a( i+1, i+1 ), lda )
306*
307 a( i+1, i ) = e( i )
308 END IF
309 d( i ) = a( i, i )
310 tau( i ) = taui
311 20 CONTINUE
312 d( n ) = a( n, n )
313 END IF
314*
315 RETURN
316*
317* End of SSYTD2
318*
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106
sdot
real function sdot(n, sx, incx, sy, incy)
SDOT
Definition sdot.f:82

◆ ssytf2()

subroutine ssytf2 ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

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

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

Purpose:
!>
!> SSYTF2 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 REAL 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. SISNAN(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 194 of file ssytf2.f.

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

◆ ssytf2_rook()

subroutine ssytf2_rook ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

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

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

Purpose:
!>
!> SSYTF2_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 REAL 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 ssytf2_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 REAL A( LDA, * )
206* ..
207*
208* =====================================================================
209*
210* .. Parameters ..
211 REAL ZERO, ONE
212 parameter( zero = 0.0e+0, one = 1.0e+0 )
213 REAL EIGHT, SEVTEN
214 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
215* ..
216* .. Local Scalars ..
217 LOGICAL UPPER, DONE
218 INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
219 $ P, II
220 REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
221 $ ROWMAX, STEMP, T, WK, WKM1, WKP1, SFMIN
222* ..
223* .. External Functions ..
224 LOGICAL LSAME
225 INTEGER ISAMAX
226 REAL SLAMCH
227 EXTERNAL lsame, isamax, slamch
228* ..
229* .. External Subroutines ..
230 EXTERNAL sscal, sswap, ssyr, 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( 'SSYTF2_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 = slamch( '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 = isamax( 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 + isamax( 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 = isamax( imax-1, a( 1, imax ), 1 )
338 stemp = abs( a( itemp, imax ) )
339 IF( stemp.GT.rowmax ) THEN
340 rowmax = stemp
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 sswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
394 IF( p.LT.(k-1) )
395 $ CALL sswap( 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 sswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
412 IF( ( kk.GT.1 ) .AND. ( kp.LT.(kk-1) ) )
413 $ CALL sswap( 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 ssyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
448*
449* Store U(k) in column k
450*
451 CALL sscal( 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 ssyr( 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 + isamax( 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 + isamax( 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 + isamax( n-imax, a( imax+1, imax ),
604 $ 1 )
605 stemp = abs( a( itemp, imax ) )
606 IF( stemp.GT.rowmax ) THEN
607 rowmax = stemp
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 sswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
661 IF( p.GT.(k+1) )
662 $ CALL sswap( 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 sswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
678 IF( ( kk.LT.n ) .AND. ( kp.GT.(kk+1) ) )
679 $ CALL sswap( 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 ssyr( 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 sscal( 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 ssyr( 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 SSYTF2_ROOK
809*

◆ ssytrd()

subroutine ssytrd ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SSYTRD

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

Purpose:
!>
!> SSYTRD 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 REAL 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 REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL 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 REAL array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is REAL 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 ssytrd.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 REAL A( LDA, * ), D( * ), E( * ), TAU( * ),
203 $ WORK( * )
204* ..
205*
206* =====================================================================
207*
208* .. Parameters ..
209 REAL ONE
210 parameter( one = 1.0e+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 slatrd, ssyr2k, ssytd2, 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, 'SSYTRD', 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( 'SSYTRD', -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, 'SSYTRD', 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, 'SSYTRD', 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 slatrd( 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 ssyr2k( 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 ssytd2( 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 slatrd( 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 ssyr2k( 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 ssytd2( 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 SSYTRD
372*
slatrd
subroutine slatrd(uplo, n, nb, a, lda, e, tau, w, ldw)
SLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal fo...
Definition slatrd.f:198
ssytd2
subroutine ssytd2(uplo, n, a, lda, d, e, tau, info)
SSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity tran...
Definition ssytd2.f:173

◆ ssytrd_2stage()

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

SSYTRD_2STAGE

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

Purpose:
!>
!> SSYTRD_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 REAL 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 REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!>
[out]E
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T.
!>
[out]TAU
!>          TAU is REAL array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors of 
!>          the first stage (see Further Details).
!>
[out]HOUS2
!>          HOUS2 is REAL 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 REAL 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 ssytrd_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 REAL D( * ), E( * )
237 REAL 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, ssytrd_sy2sb, ssytrd_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, 'SSYTRD_2STAGE', vect, n, -1, -1, -1 )
267 ib = ilaenv2stage( 2, 'SSYTRD_2STAGE', vect, n, kd, -1, -1 )
268 lhmin = ilaenv2stage( 3, 'SSYTRD_2STAGE', vect, n, kd, ib, -1 )
269 lwmin = ilaenv2stage( 4, 'SSYTRD_2STAGE', vect, n, kd, ib, -1 )
270* WRITE(*,*),'SSYTRD_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( 'SSYTRD_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 ssytrd_sy2sb( uplo, n, kd, a, lda, work( abpos ), ldab,
313 $ tau, work( wpos ), lwrk, info )
314 IF( info.NE.0 ) THEN
315 CALL xerbla( 'SSYTRD_SY2SB', -info )
316 RETURN
317 END IF
318 CALL ssytrd_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( 'SSYTRD_SB2ST', -info )
323 RETURN
324 END IF
325*
326*
327 hous2( 1 ) = lhmin
328 work( 1 ) = lwmin
329 RETURN
330*
331* End of SSYTRD_2STAGE
332*
ilaenv2stage
integer function ilaenv2stage(ispec, name, opts, n1, n2, n3, n4)
ILAENV2STAGE
Definition ilaenv2stage.f:149
ssytrd_sy2sb
subroutine ssytrd_sy2sb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
SSYTRD_SY2SB
Definition ssytrd_sy2sb.f:243
ssytrd_sb2st
subroutine ssytrd_sb2st(stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T
Definition ssytrd_sb2st.F:230

◆ ssytrd_sy2sb()

subroutine ssytrd_sy2sb ( character uplo,
integer n,
integer kd,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SSYTRD_SY2SB

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

Purpose:
!>
!> SSYTRD_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 REAL 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 REAL 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 REAL array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is REAL 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 ssytrd_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 REAL A( LDA, * ), AB( LDAB, * ),
256 $ TAU( * ), WORK( * )
257* ..
258*
259* =====================================================================
260*
261* .. Parameters ..
262 REAL RONE
263 REAL ZERO, ONE, HALF
264 parameter( rone = 1.0e+0,
265 $ zero = 0.0e+0,
266 $ one = 1.0e+0,
267 $ half = 0.5e+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, ssyr2k, ssymm, sgemm, scopy,
278 $ slarft, sgelqf, sgeqrf, slaset
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, 'SSYTRD_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( 'SSYTRD_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 scopy( 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 scopy( 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 slaset( "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 sgelqf( 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 scopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
382 20 CONTINUE
383*
384 CALL slaset( 'Lower', pk, pk, zero, one,
385 $ a( i, i+kd ), lda )
386*
387* Form the matrix T
388*
389 CALL slarft( 'Forward', 'Rowwise', pn, pk,
390 $ a( i, i+kd ), lda, tau( i ),
391 $ work( tpos ), ldt )
392*
393* Compute W:
394*
395 CALL sgemm( '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 ssymm( 'Right', uplo, pk, pn,
401 $ one, a( i+kd, i+kd ), lda,
402 $ work( s2pos ), lds2,
403 $ zero, work( wpos ), ldw )
404*
405 CALL sgemm( 'No transpose', 'Conjugate', pk, pk, pn,
406 $ one, work( wpos ), ldw,
407 $ work( s2pos ), lds2,
408 $ zero, work( s1pos ), lds1 )
409*
410 CALL sgemm( '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 ssyr2k( 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 scopy( 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 sgeqrf( 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 scopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
450 50 CONTINUE
451*
452 CALL slaset( 'Upper', pk, pk, zero, one,
453 $ a( i+kd, i ), lda )
454*
455* Form the matrix T
456*
457 CALL slarft( 'Forward', 'Columnwise', pn, pk,
458 $ a( i+kd, i ), lda, tau( i ),
459 $ work( tpos ), ldt )
460*
461* Compute W:
462*
463 CALL sgemm( '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 ssymm( 'Left', uplo, pn, pk,
469 $ one, a( i+kd, i+kd ), lda,
470 $ work( s2pos ), lds2,
471 $ zero, work( wpos ), ldw )
472*
473 CALL sgemm( 'Conjugate', 'No transpose', pk, pk, pn,
474 $ one, work( s2pos ), lds2,
475 $ work( wpos ), ldw,
476 $ zero, work( s1pos ), lds1 )
477*
478 CALL sgemm( '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 ssyr2k( 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 SCOPY( 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 scopy( 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 SSYTRD_SY2SB
513*
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
sgelqf
subroutine sgelqf(m, n, a, lda, tau, work, lwork, info)
SGELQF
Definition sgelqf.f:143
slarft
subroutine slarft(direct, storev, n, k, v, ldv, tau, t, ldt)
SLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition slarft.f:163

◆ ssytrf()

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

SSYTRF

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

Purpose:
!>
!> SSYTRF 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 REAL 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 REAL 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 ssytrf.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 REAL 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 slasyf, ssytf2, 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, 'SSYTRF', 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( 'SSYTRF', -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, 'SSYTRF', 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 SLASYF;
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 slasyf( 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 ssytf2( 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 SLASYF;
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 slasyf( 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 ssytf2( 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 SSYTRF
359*
ssytf2
subroutine ssytf2(uplo, n, a, lda, ipiv, info)
SSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting ...
Definition ssytf2.f:195
slasyf
subroutine slasyf(uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
SLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal p...
Definition slasyf.f:176

◆ ssytrf_aa()

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

SSYTRF_AA

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

Purpose:
!>
!> SSYTRF_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 REAL 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 REAL 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 ssytrf_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 REAL A( LDA, * ), WORK( * )
146* ..
147*
148* =====================================================================
149* .. Parameters ..
150 REAL ZERO, ONE
151 parameter( zero = 0.0e+0, one = 1.0e+0 )
152*
153* .. Local Scalars ..
154 LOGICAL LQUERY, UPPER
155 INTEGER J, LWKOPT
156 INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB
157 REAL ALPHA
158* ..
159* .. External Functions ..
160 LOGICAL LSAME
161 INTEGER ILAENV
162 EXTERNAL lsame, ilaenv
163* ..
164* .. External Subroutines ..
165 EXTERNAL slasyf_aa, sgemv, sscal, scopy, sswap, sgemm,
166 $ xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max
170* ..
171* .. Executable Statements ..
172*
173* Determine the block size
174*
175 nb = ilaenv( 1, 'SSYTRF_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( 'SSYTRF_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 scopy( 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 SLASYF;
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 slasyf_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 sswap( 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 scopy( n-j, a( j-1, j+1 ), lda,
282 $ work( (j+1-j1+1)+jb*n ), 1 )
283 CALL sscal( 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 SGEMV
309*
310 j3 = j2
311 DO mj = nj-1, 1, -1
312 CALL sgemv( '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 SGEMM
320*
321 CALL sgemm( '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 scopy( 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 scopy( 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 SLASYF;
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 slasyf_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 sswap( 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 scopy( n-j, a( j+1, j-1 ), 1,
401 $ work( (j+1-j1+1)+jb*n ), 1 )
402 CALL sscal( 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 SGEMV
428*
429 j3 = j2
430 DO mj = nj-1, 1, -1
431 CALL sgemv( '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 SGEMM
439*
440 CALL sgemm( '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 scopy( 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 SSYTRF_AA
464*
slasyf_aa
subroutine slasyf_aa(uplo, j1, m, nb, a, lda, ipiv, h, ldh, work)
SLASYF_AA
Definition slasyf_aa.f:144

◆ ssytrf_aa_2stage()

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

SSYTRF_AA_2STAGE

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

Purpose:
!>
!> SSYTRF_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 REAL 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 REAL array, dimension (LTB)
!>          On exit, details of the LU factorization of the band matrix.
!>
[in]LTB
!>          LTB is INTEGER
!>          The size of the array TB. LTB >= 4*N, internally
!>          used to select NB such that LTB >= (3*NB+1)*N.
!>
!>          If LTB = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of LTB, 
!>          returns this value as the first entry of TB, and
!>          no error message related to LTB is issued by XERBLA.
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of A were interchanged with the
!>          row and column IPIV(k).
!>
[out]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          On exit, it contains the details of the interchanges, i.e.,
!>          the row and column k of T were interchanged with the
!>          row and column IPIV(k).
!>
[out]WORK
!>          WORK is REAL 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 ssytrf_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 REAL A( LDA, * ), TB( * ), WORK( * )
174* ..
175*
176* =====================================================================
177* .. Parameters ..
178 REAL ZERO, ONE
179 parameter( zero = 0.0e+0, one = 1.0e+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 REAL PIV
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 INTEGER ILAENV
190 EXTERNAL lsame, ilaenv
191* ..
192* .. External Subroutines ..
193 EXTERNAL xerbla, scopy, slacpy,
194 $ slaset, sgbtrf, sgemm, sgetrf,
195 $ ssygst, sswap, strsm
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( 'SSYTRF_AA_2STAGE', -info )
222 RETURN
223 END IF
224*
225* Answer the query
226*
227 nb = ilaenv( 1, 'SSYTRF_AA_2STAGE', uplo, n, -1, -1, -1 )
228 IF( info.EQ.0 ) THEN
229 IF( tquery ) THEN
230 tb( 1 ) = (3*nb+1)*n
231 END IF
232 IF( wquery ) THEN
233 work( 1 ) = n*nb
234 END IF
235 END IF
236 IF( tquery .OR. wquery ) THEN
237 RETURN
238 END IF
239*
240* Quick return
241*
242 IF ( n.EQ.0 ) THEN
243 RETURN
244 ENDIF
245*
246* Determine the number of the block size
247*
248 ldtb = ltb/n
249 IF( ldtb .LT. 3*nb+1 ) THEN
250 nb = (ldtb-1)/3
251 END IF
252 IF( lwork .LT. nb*n ) THEN
253 nb = lwork/n
254 END IF
255*
256* Determine the number of the block columns
257*
258 nt = (n+nb-1)/nb
259 td = 2*nb
260 kb = min(nb, n)
261*
262* Initialize vectors/matrices
263*
264 DO j = 1, kb
265 ipiv( j ) = j
266 END DO
267*
268* Save NB
269*
270 tb( 1 ) = nb
271*
272 IF( upper ) THEN
273*
274* .....................................................
275* Factorize A as U**T*D*U using the upper triangle of A
276* .....................................................
277*
278 DO j = 0, nt-1
279*
280* Generate Jth column of W and H
281*
282 kb = min(nb, n-j*nb)
283 DO i = 1, j-1
284 IF( i.EQ.1 ) THEN
285* H(I,J) = T(I,I)*U(I,J) + T(I+1,I)*U(I+1,J)
286 IF( i .EQ. (j-1) ) THEN
287 jb = nb+kb
288 ELSE
289 jb = 2*nb
290 END IF
291 CALL sgemm( '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 sgemm( '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 slacpy( '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 sgemm( '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 sgemm( '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 sgemm( '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 ssygst( 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 sgemm( '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 sgemm( '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 sgemm( '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 SGETRF
380*
381 DO k = 1, nb
382 CALL scopy( 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 sgetrf( 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 scopy( 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 slaset( 'Full', kb, nb, zero, zero,
408 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
409 CALL slacpy( 'Upper', kb, nb,
410 $ work, n,
411 $ tb( td+nb+1 + (j*nb)*ldtb ), ldtb-1 )
412 IF( j.GT.0 ) THEN
413 CALL strsm( '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 slaset( '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 sswap( 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 sswap( 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 sswap( 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 sswap( 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 sgemm( '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 sgemm( '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 slacpy( '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 sgemm( '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 sgemm( '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 sgemm( '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 ssygst( 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 sgemm( '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 sgemm( '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 sgemm( '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 sgetrf( 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 slaset( 'Full', kb, nb, zero, zero,
583 $ tb( td+nb+1 + (j*nb)*ldtb), ldtb-1 )
584 CALL slacpy( '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 strsm( '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 slaset( '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 sswap( 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 sswap( 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 sswap( 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 sswap( 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 SLASWP( 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 sgbtrf( n, n, nb, nb, tb, ldtb, ipiv2, info )
647*
648 RETURN
649*
650* End of SSYTRF_AA_2STAGE
651*
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
sgbtrf
subroutine sgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
SGBTRF
Definition sgbtrf.f:144
sgetrf
subroutine sgetrf(m, n, a, lda, ipiv, info)
SGETRF
Definition sgetrf.f:108
ssygst
subroutine ssygst(itype, uplo, n, a, lda, b, ldb, info)
SSYGST
Definition ssygst.f:127

◆ ssytrf_rook()

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

SSYTRF_ROOK

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

Purpose:
!>
!> SSYTRF_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 REAL 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 REAL array, dimension (MAX(1,LWORK)).
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK >=1.  For best performance
!>          LWORK >= N*NB, where NB is the block size returned by ILAENV.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization
!>                has been completed, but the block diagonal matrix D is
!>                exactly singular, and division by zero will occur if it
!>                is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', then A = U*D*U**T, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>
Contributors:
!>
!>   June 2016, Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!>

Definition at line 207 of file ssytrf_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 REAL 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 slasyf_rook, ssytf2_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, 'SSYTRF_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( 'SSYTRF_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, 'SSYTRF_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 SLASYF_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 slasyf_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 ssytf2_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 SLASYF_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 slasyf_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 ssytf2_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 SSYTRF_ROOK
389*
slasyf_rook
subroutine slasyf_rook(uplo, n, nb, kb, a, lda, ipiv, w, ldw, info)
SLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufm...
Definition slasyf_rook.f:184
ssytf2_rook
subroutine ssytf2_rook(uplo, n, a, lda, ipiv, info)
SSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-...
Definition ssytf2_rook.f:194

◆ ssytri()

subroutine ssytri ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
real, dimension( * ) work,
integer info )

SSYTRI

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

Purpose:
!>
!> SSYTRI 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
!> SSYTRF.
!>
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 REAL 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 SSYTRF.
!>
!>          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 SSYTRF.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 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 ssytri.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 REAL A( LDA, * ), WORK( * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 REAL ONE, ZERO
132 parameter( one = 1.0e+0, zero = 0.0e+0 )
133* ..
134* .. Local Scalars ..
135 LOGICAL UPPER
136 INTEGER K, KP, KSTEP
137 REAL AK, AKKP1, AKP1, D, T, TEMP
138* ..
139* .. External Functions ..
140 LOGICAL LSAME
141 REAL SDOT
142 EXTERNAL lsame, sdot
143* ..
144* .. External Subroutines ..
145 EXTERNAL scopy, sswap, ssymv, 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( 'SSYTRI', -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 scopy( k-1, a( 1, k ), 1, work, 1 )
221 CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero,
222 $ a( 1, k ), 1 )
223 a( k, k ) = a( k, k ) - sdot( 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 scopy( k-1, a( 1, k ), 1, work, 1 )
246 CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero,
247 $ a( 1, k ), 1 )
248 a( k, k ) = a( k, k ) - sdot( k-1, work, 1, a( 1, k ),
249 $ 1 )
250 a( k, k+1 ) = a( k, k+1 ) -
251 $ sdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
252 CALL scopy( k-1, a( 1, k+1 ), 1, work, 1 )
253 CALL ssymv( 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 $ sdot( 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 sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
268 CALL sswap( 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 scopy( n-k, a( k+1, k ), 1, work, 1 )
310 CALL ssymv( 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 ) - sdot( 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 scopy( n-k, a( k+1, k ), 1, work, 1 )
335 CALL ssymv( 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 ) - sdot( n-k, work, 1, a( k+1, k ),
338 $ 1 )
339 a( k, k-1 ) = a( k, k-1 ) -
340 $ sdot( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
341 $ 1 )
342 CALL scopy( n-k, a( k+1, k-1 ), 1, work, 1 )
343 CALL ssymv( 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 $ sdot( 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 sswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
359 CALL sswap( 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 SSYTRI
378*

◆ ssytri2()

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

SSYTRI2

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

Purpose:
!>
!> SSYTRI2 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
!> SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace
!> before calling SSYTRI2X 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 REAL 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 SSYTRF.
!>
!>          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 SSYTRF.
!>
[out]WORK
!>          WORK is REAL 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 ssytri2.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 REAL 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 ssytri, ssytri2x, 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, 'SSYTRF', 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( 'SSYTRI2', -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 ssytri( uplo, n, a, lda, ipiv, work, info )
195 ELSE
196 CALL ssytri2x( uplo, n, a, lda, ipiv, work, nbmax, info )
197 END IF
198 RETURN
199*
200* End of SSYTRI2
201*
ssytri
subroutine ssytri(uplo, n, a, lda, ipiv, work, info)
SSYTRI
Definition ssytri.f:114
ssytri2x
subroutine ssytri2x(uplo, n, a, lda, ipiv, work, nb, info)
SSYTRI2X
Definition ssytri2x.f:120

◆ ssytri2x()

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

SSYTRI2X

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

Purpose:
!>
!> SSYTRI2X 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
!> SSYTRF.
!>
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 REAL 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 SSYTRF.
!>
!>          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 SSYTRF.
!>
[out]WORK
!>          WORK is REAL array, dimension (N+NB+1,NB+3)
!>
[in]NB
!>          NB is INTEGER
!>          Block size
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
!>               inverse could not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file ssytri2x.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 REAL A( LDA, * ), WORK( N+NB+1,* )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 REAL ONE, ZERO
138 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AK, AKKP1, AKP1, D, T
147 REAL U01_I_J, U01_IP1_J
148 REAL U11_I_J, U11_IP1_J
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 EXTERNAL lsame
153* ..
154* .. External Subroutines ..
155 EXTERNAL ssyconv, xerbla, strtri
156 EXTERNAL sgemm, strmm, ssyswapr
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( 'SSYTRI2X', -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 ssyconv( 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 strtri( 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 strmm('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 sgemm('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* U11 = U11**T*invD1*U11 + U01**T*invD*U01
353*
354 DO i=1,nnb
355 DO j=i,nnb
356 a(cut+i,cut+j)=a(cut+i,cut+j)+work(u11+i,j)
357 END DO
358 END DO
359*
360* U01 = U00**T*invD0*U01
361*
362 CALL strmm('L',uplo,'T','U',cut, nnb,
363 $ one,a,lda,work,n+nb+1)
364
365*
366* Update U01
367*
368 DO i=1,cut
369 DO j=1,nnb
370 a(i,cut+j)=work(i,j)
371 END DO
372 END DO
373*
374* Next Block
375*
376 END DO
377*
378* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T
379*
380 i=1
381 DO WHILE ( i .LE. n )
382 IF( ipiv(i) .GT. 0 ) THEN
383 ip=ipiv(i)
384 IF (i .LT. ip) CALL ssyswapr( uplo, n, a, lda, i ,ip )
385 IF (i .GT. ip) CALL ssyswapr( uplo, n, a, lda, ip ,i )
386 ELSE
387 ip=-ipiv(i)
388 i=i+1
389 IF ( (i-1) .LT. ip)
390 $ CALL ssyswapr( uplo, n, a, lda, i-1 ,ip )
391 IF ( (i-1) .GT. ip)
392 $ CALL ssyswapr( uplo, n, a, lda, ip ,i-1 )
393 ENDIF
394 i=i+1
395 END DO
396 ELSE
397*
398* LOWER...
399*
400* invA = P * inv(U**T)*inv(D)*inv(U)*P**T.
401*
402 CALL strtri( uplo, 'U', n, a, lda, info )
403*
404* inv(D) and inv(D)*inv(U)
405*
406 k=n
407 DO WHILE ( k .GE. 1 )
408 IF( ipiv( k ).GT.0 ) THEN
409* 1 x 1 diagonal NNB
410 work(k,invd) = one / a( k, k )
411 work(k,invd+1) = 0
412 k=k-1
413 ELSE
414* 2 x 2 diagonal NNB
415 t = work(k-1,1)
416 ak = a( k-1, k-1 ) / t
417 akp1 = a( k, k ) / t
418 akkp1 = work(k-1,1) / t
419 d = t*( ak*akp1-one )
420 work(k-1,invd) = akp1 / d
421 work(k,invd) = ak / d
422 work(k,invd+1) = -akkp1 / d
423 work(k-1,invd+1) = -akkp1 / d
424 k=k-2
425 END IF
426 END DO
427*
428* inv(U**T) = (inv(U))**T
429*
430* inv(U**T)*inv(D)*inv(U)
431*
432 cut=0
433 DO WHILE (cut .LT. n)
434 nnb=nb
435 IF (cut + nnb .GT. n) THEN
436 nnb=n-cut
437 ELSE
438 count = 0
439* count negative elements,
440 DO i=cut+1,cut+nnb
441 IF (ipiv(i) .LT. 0) count=count+1
442 END DO
443* need a even number for a clear cut
444 IF (mod(count,2) .EQ. 1) nnb=nnb+1
445 END IF
446* L21 Block
447 DO i=1,n-cut-nnb
448 DO j=1,nnb
449 work(i,j)=a(cut+nnb+i,cut+j)
450 END DO
451 END DO
452* L11 Block
453 DO i=1,nnb
454 work(u11+i,i)=one
455 DO j=i+1,nnb
456 work(u11+i,j)=zero
457 END DO
458 DO j=1,i-1
459 work(u11+i,j)=a(cut+i,cut+j)
460 END DO
461 END DO
462*
463* invD*L21
464*
465 i=n-cut-nnb
466 DO WHILE (i .GE. 1)
467 IF (ipiv(cut+nnb+i) > 0) THEN
468 DO j=1,nnb
469 work(i,j)=work(cut+nnb+i,invd)*work(i,j)
470 END DO
471 i=i-1
472 ELSE
473 DO j=1,nnb
474 u01_i_j = work(i,j)
475 u01_ip1_j = work(i-1,j)
476 work(i,j)=work(cut+nnb+i,invd)*u01_i_j+
477 $ work(cut+nnb+i,invd+1)*u01_ip1_j
478 work(i-1,j)=work(cut+nnb+i-1,invd+1)*u01_i_j+
479 $ work(cut+nnb+i-1,invd)*u01_ip1_j
480 END DO
481 i=i-2
482 END IF
483 END DO
484*
485* invD1*L11
486*
487 i=nnb
488 DO WHILE (i .GE. 1)
489 IF (ipiv(cut+i) > 0) THEN
490 DO j=1,nnb
491 work(u11+i,j)=work(cut+i,invd)*work(u11+i,j)
492 END DO
493 i=i-1
494 ELSE
495 DO j=1,nnb
496 u11_i_j = work(u11+i,j)
497 u11_ip1_j = work(u11+i-1,j)
498 work(u11+i,j)=work(cut+i,invd)*work(u11+i,j) +
499 $ work(cut+i,invd+1)*u11_ip1_j
500 work(u11+i-1,j)=work(cut+i-1,invd+1)*u11_i_j+
501 $ work(cut+i-1,invd)*u11_ip1_j
502 END DO
503 i=i-2
504 END IF
505 END DO
506*
507* L11**T*invD1*L11->L11
508*
509 CALL strmm('L',uplo,'T','U',nnb, nnb,
510 $ one,a(cut+1,cut+1),lda,work(u11+1,1),n+nb+1)
511
512*
513 DO i=1,nnb
514 DO j=1,i
515 a(cut+i,cut+j)=work(u11+i,j)
516 END DO
517 END DO
518*
519 IF ( (cut+nnb) .LT. n ) THEN
520*
521* L21**T*invD2*L21->A(CUT+I,CUT+J)
522*
523 CALL sgemm('T','N',nnb,nnb,n-nnb-cut,one,a(cut+nnb+1,cut+1)
524 $ ,lda,work,n+nb+1, zero, work(u11+1,1), n+nb+1)
525
526*
527* L11 = L11**T*invD1*L11 + U01**T*invD*U01
528*
529 DO i=1,nnb
530 DO j=1,i
531 a(cut+i,cut+j)=a(cut+i,cut+j)+work(u11+i,j)
532 END DO
533 END DO
534*
535* L01 = L22**T*invD2*L21
536*
537 CALL strmm('L',uplo,'T','U', n-nnb-cut, nnb,
538 $ one,a(cut+nnb+1,cut+nnb+1),lda,work,n+nb+1)
539*
540* Update L21
541*
542 DO i=1,n-cut-nnb
543 DO j=1,nnb
544 a(cut+nnb+i,cut+j)=work(i,j)
545 END DO
546 END DO
547
548 ELSE
549*
550* L11 = L11**T*invD1*L11
551*
552 DO i=1,nnb
553 DO j=1,i
554 a(cut+i,cut+j)=work(u11+i,j)
555 END DO
556 END DO
557 END IF
558*
559* Next Block
560*
561 cut=cut+nnb
562 END DO
563*
564* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T
565*
566 i=n
567 DO WHILE ( i .GE. 1 )
568 IF( ipiv(i) .GT. 0 ) THEN
569 ip=ipiv(i)
570 IF (i .LT. ip) CALL ssyswapr( uplo, n, a, lda, i ,ip )
571 IF (i .GT. ip) CALL ssyswapr( uplo, n, a, lda, ip ,i )
572 ELSE
573 ip=-ipiv(i)
574 IF ( i .LT. ip) CALL ssyswapr( uplo, n, a, lda, i ,ip )
575 IF ( i .GT. ip) CALL ssyswapr( uplo, n, a, lda, ip ,i )
576 i=i-1
577 ENDIF
578 i=i-1
579 END DO
580 END IF
581*
582 RETURN
583*
584* End of SSYTRI2X
585*
strtri
subroutine strtri(uplo, diag, n, a, lda, info)
STRTRI
Definition strtri.f:109
ssyswapr
subroutine ssyswapr(uplo, n, a, lda, i1, i2)
SSYSWAPR applies an elementary permutation on the rows and columns of a symmetric matrix.
Definition ssyswapr.f:102
ssyconv
subroutine ssyconv(uplo, way, n, a, lda, ipiv, e, info)
SSYCONV
Definition ssyconv.f:114

◆ ssytri_rook()

subroutine ssytri_rook ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
real, dimension( * ) work,
integer info )

SSYTRI_ROOK

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

Purpose:
!>
!> SSYTRI_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 SSYTRF_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 REAL 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 SSYTRF_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 SSYTRF_ROOK.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 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 ssytri_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 REAL A( LDA, * ), WORK( * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 REAL ONE, ZERO
147 parameter( one = 1.0e+0, zero = 0.0e+0 )
148* ..
149* .. Local Scalars ..
150 LOGICAL UPPER
151 INTEGER K, KP, KSTEP
152 REAL AK, AKKP1, AKP1, D, T, TEMP
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 REAL SDOT
157 EXTERNAL lsame, sdot
158* ..
159* .. External Subroutines ..
160 EXTERNAL scopy, sswap, ssymv, 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( 'SSYTRI_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 scopy( k-1, a( 1, k ), 1, work, 1 )
236 CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero,
237 $ a( 1, k ), 1 )
238 a( k, k ) = a( k, k ) - sdot( 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 scopy( k-1, a( 1, k ), 1, work, 1 )
261 CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero,
262 $ a( 1, k ), 1 )
263 a( k, k ) = a( k, k ) - sdot( k-1, work, 1, a( 1, k ),
264 $ 1 )
265 a( k, k+1 ) = a( k, k+1 ) -
266 $ sdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
267 CALL scopy( k-1, a( 1, k+1 ), 1, work, 1 )
268 CALL ssymv( 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 $ sdot( 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 sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
285 CALL sswap( 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 sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
299 CALL sswap( 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 sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
314 CALL sswap( 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 scopy( n-k, a( k+1, k ), 1, work, 1 )
352 CALL ssymv( 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 ) - sdot( 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 scopy( n-k, a( k+1, k ), 1, work, 1 )
377 CALL ssymv( 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 ) - sdot( n-k, work, 1, a( k+1, k ),
380 $ 1 )
381 a( k, k-1 ) = a( k, k-1 ) -
382 $ sdot( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
383 $ 1 )
384 CALL scopy( n-k, a( k+1, k-1 ), 1, work, 1 )
385 CALL ssymv( 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 $ sdot( 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 sswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
402 CALL sswap( 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 sswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
416 CALL sswap( 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 sswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
431 CALL sswap( 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 SSYTRI_ROOK
446*

◆ ssytrs()

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

SSYTRS

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

Purpose:
!>
!> SSYTRS 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 SSYTRF.
!>
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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF.
!>
[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 SSYTRF.
!>
[in,out]B
!>          B is REAL 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 ssytrs.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 REAL A( LDA, * ), B( LDB, * )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 REAL ONE
138 parameter( one = 1.0e+0 )
139* ..
140* .. Local Scalars ..
141 LOGICAL UPPER
142 INTEGER J, K, KP
143 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
144* ..
145* .. External Functions ..
146 LOGICAL LSAME
147 EXTERNAL lsame
148* ..
149* .. External Subroutines ..
150 EXTERNAL sgemv, sger, sscal, sswap, 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( 'SSYTRS', -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 sswap( 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 sger( 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 sscal( 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 sswap( 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 sger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,
231 $ b( 1, 1 ), ldb )
232 CALL sger( 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 sgemv( '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 sswap( 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 sgemv( 'Transpose', k-1, nrhs, -one, b, ldb, a( 1, k ),
290 $ 1, one, b( k, 1 ), ldb )
291 CALL sgemv( '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 sswap( 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 sswap( 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 sger( 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 sscal( 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 sswap( 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 sger( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
358 $ ldb, b( k+2, 1 ), ldb )
359 CALL sger( 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 sgemv( '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 sswap( 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 sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
420 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
421 CALL sgemv( '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 sswap( 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 SSYTRS
441*
sger
subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
SGER
Definition sger.f:130

◆ ssytrs2()

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

SSYTRS2

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

Purpose:
!>
!> SSYTRS2 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 SSYTRF and converted by SSYCONV.
!>
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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF.
!>          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 SSYTRF.
!>
[in,out]B
!>          B is REAL 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 REAL 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 ssytrs2.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 REAL A( LDA, * ), B( LDB, * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 REAL ONE
150 parameter( one = 1.0e+0 )
151* ..
152* .. Local Scalars ..
153 LOGICAL UPPER
154 INTEGER I, IINFO, J, K, KP
155 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
156* ..
157* .. External Functions ..
158 LOGICAL LSAME
159 EXTERNAL lsame
160* ..
161* .. External Subroutines ..
162 EXTERNAL sscal, ssyconv, sswap, strsm, 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( 'SSYTRS2', -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 ssyconv( 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 sswap( 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 sswap( 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 strsm('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 sscal( 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 strsm('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 sswap( 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 sswap( 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 sswap( 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 sswap( 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 strsm('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 sscal( 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 strsm('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 sswap( 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 sswap( 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 ssyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
353*
354 RETURN
355*
356* End of SSYTRS2
357*

◆ ssytrs_aa()

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

SSYTRS_AA

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

Purpose:
!>
!> SSYTRS_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 SSYTRF_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 REAL array, dimension (LDA,N)
!>          Details of factors computed by SSYTRF_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 SSYTRF_AA.
!>
[in,out]B
!>          B is REAL 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 REAL 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 ssytrs_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 REAL A( LDA, * ), B( LDB, * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149 REAL ONE
150 parameter( one = 1.0e+0 )
151* ..
152* .. Local Scalars ..
153 LOGICAL LQUERY, UPPER
154 INTEGER K, KP, LWKOPT
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL sgtsv, sswap, slacpy, strsm, 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( 'SSYTRS_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 k = 1
209 DO WHILE ( k.LE.n )
210 kp = ipiv( k )
211 IF( kp.NE.k )
212 $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
213 k = k + 1
214 END DO
215*
216* Compute U**T \ B -> B [ (U**T \P**T * B) ]
217*
218 CALL strsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),
219 $ lda, b( 2, 1 ), ldb)
220 END IF
221*
222* 2) Solve with triangular matrix T
223*
224* Compute T \ B -> B [ T \ (U**T \P**T * B) ]
225*
226 CALL slacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
227 IF( n.GT.1 ) THEN
228 CALL slacpy( 'F', 1, n-1, a(1, 2), lda+1, work(1), 1)
229 CALL slacpy( 'F', 1, n-1, a(1, 2), lda+1, work(2*n), 1)
230 END IF
231 CALL sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,
232 $ info)
233*
234* 3) Backward substitution with U
235*
236 IF( n.GT.1 ) THEN
237*
238*
239* Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ]
240*
241 CALL strsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),
242 $ lda, b(2, 1), ldb)
243*
244* Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ]
245*
246 k = n
247 DO WHILE ( k.GE.1 )
248 kp = ipiv( k )
249 IF( kp.NE.k )
250 $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
251 k = k - 1
252 END DO
253 END IF
254*
255 ELSE
256*
257* Solve A*X = B, where A = L*T*L**T.
258*
259* 1) Forward substitution with L
260*
261 IF( n.GT.1 ) THEN
262*
263* Pivot, P**T * B -> B
264*
265 k = 1
266 DO WHILE ( k.LE.n )
267 kp = ipiv( k )
268 IF( kp.NE.k )
269 $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
270 k = k + 1
271 END DO
272*
273* Compute L \ B -> B [ (L \P**T * B) ]
274*
275 CALL strsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1),
276 $ lda, b(2, 1), ldb)
277 END IF
278*
279* 2) Solve with triangular matrix T
280*
281* Compute T \ B -> B [ T \ (L \P**T * B) ]
282*
283 CALL slacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
284 IF( n.GT.1 ) THEN
285 CALL slacpy( 'F', 1, n-1, a(2, 1), lda+1, work(1), 1)
286 CALL slacpy( 'F', 1, n-1, a(2, 1), lda+1, work(2*n), 1)
287 END IF
288 CALL sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,
289 $ info)
290*
291* 3) Backward substitution with L**T
292*
293 IF( n.GT.1 ) THEN
294*
295* Compute L**T \ B -> B [ L**T \ (T \ (L \P**T * B) ) ]
296*
297 CALL strsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),
298 $ lda, b( 2, 1 ), ldb)
299*
300* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
301*
302 k = n
303 DO WHILE ( k.GE.1 )
304 kp = ipiv( k )
305 IF( kp.NE.k )
306 $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
307 k = k - 1
308 END DO
309 END IF
310*
311 END IF
312*
313 RETURN
314*
315* End of SSYTRS_AA
316*
sgtsv
subroutine sgtsv(n, nrhs, dl, d, du, b, ldb, info)
SGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition sgtsv.f:127

◆ ssytrs_aa_2stage()

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

SSYTRS_AA_2STAGE

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

Purpose:
!>
!> SSYTRS_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 SSYTRF_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 REAL array, dimension (LDA,N)
!>          Details of factors computed by SSYTRF_AA_2STAGE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TB
!>          TB is REAL array, dimension (LTB)
!>          Details of factors computed by SSYTRF_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
!>          SSYTRF_AA_2STAGE.
!>
[in]IPIV2
!>          IPIV2 is INTEGER array, dimension (N)
!>          Details of the interchanges as computed by
!>          SSYTRF_AA_2STAGE.
!>
[in,out]B
!>          B is REAL 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 ssytrs_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 REAL A( LDA, * ), TB( * ), B( LDB, * )
153* ..
154*
155* =====================================================================
156*
157 REAL ONE
158 parameter( one = 1.0e+0 )
159* ..
160* .. Local Scalars ..
161 INTEGER LDTB, NB
162 LOGICAL UPPER
163* ..
164* .. External Functions ..
165 LOGICAL LSAME
166 EXTERNAL lsame
167* ..
168* .. External Subroutines ..
169 EXTERNAL sgbtrs, slaswp, strsm, 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( 'SSYTRS_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 slaswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
215*
216* Compute (U**T \ B) -> B [ (U**T \P**T * B) ]
217*
218 CALL strsm( '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 sgbtrs( '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 strsm( '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 slaswp( 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 slaswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
249*
250* Compute (L \ B) -> B [ (L \P**T * B) ]
251*
252 CALL strsm( '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 sgbtrs( '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 strsm( '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 slaswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
271*
272 END IF
273 END IF
274*
275 RETURN
276*
277* End of SSYTRS_AA_2STAGE
278*
sgbtrs
subroutine sgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
SGBTRS
Definition sgbtrs.f:138
slaswp
subroutine slaswp(n, a, lda, k1, k2, ipiv, incx)
SLASWP performs a series of row interchanges on a general rectangular matrix.
Definition slaswp.f:115

◆ ssytrs_rook()

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

SSYTRS_ROOK

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

Purpose:
!>
!> SSYTRS_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 SSYTRF_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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF_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 SSYTRF_ROOK.
!>
[in,out]B
!>          B is REAL 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 ssytrs_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 REAL A( LDA, * ), B( LDB, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ONE
154 parameter( one = 1.0e+0 )
155* ..
156* .. Local Scalars ..
157 LOGICAL UPPER
158 INTEGER J, K, KP
159 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 EXTERNAL lsame
164* ..
165* .. External Subroutines ..
166 EXTERNAL sgemv, sger, sscal, sswap, 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( 'SSYTRS_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 sswap( 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 sger( 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 sscal( 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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
242*
243 kp = -ipiv( k-1 )
244 IF( kp.NE.k-1 )
245 $ CALL sswap( 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 sger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ),
252 $ ldb, b( 1, 1 ), ldb )
253 CALL sger( 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 sgemv( '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 sswap( 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 sgemv( 'Transpose', k-1, nrhs, -one, b,
314 $ ldb, a( 1, k ), 1, one, b( k, 1 ), ldb )
315 CALL sgemv( '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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
324*
325 kp = -ipiv( k+1 )
326 IF( kp.NE.k+1 )
327 $ CALL sswap( 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 sswap( 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 sger( 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 sscal( 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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
382*
383 kp = -ipiv( k+1 )
384 IF( kp.NE.k+1 )
385 $ CALL sswap( 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 sger( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ),
392 $ ldb, b( k+2, 1 ), ldb )
393 CALL sger( 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 sgemv( '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 sswap( 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 sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
454 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
455 CALL sgemv( '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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
465*
466 kp = -ipiv( k-1 )
467 IF( kp.NE.k-1 )
468 $ CALL sswap( 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 SSYTRS_ROOK
480*

◆ stgsyl()

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

STGSYL

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

Purpose:
!>
!> STGSYL 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', STGSYL 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 SLACON.
!>
!> If IJOB >= 1, STGSYL 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.
!>               ( SGECON 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (LDF, N)
!>          On entry, F contains the right-hand-side of the second matrix
!>          equation in (1) or (3).
!>          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
!>          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
!>          the solution achieved during the computation of the
!>          Dif-estimate.
!>
[in]LDF
!>          LDF is INTEGER
!>          The leading dimension of the array F. LDF >= max(1, M).
!>
[out]DIF
!>          DIF is REAL
!>          On exit DIF is the reciprocal of a lower bound of the
!>          reciprocal of the Dif-function, i.e. DIF is an upper bound of
!>          Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
!>          IF IJOB = 0 or TRANS = 'T', DIF is not touched.
!>
[out]SCALE
!>          SCALE is REAL
!>          On exit SCALE is the scaling factor in (1) or (3).
!>          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
!>          to a slightly perturbed system but the input matrices A, B, D
!>          and E have not been changed. If SCALE = 0, 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 REAL 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 stgsyl.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 REAL DIF, SCALE
309* ..
310* .. Array Arguments ..
311 INTEGER IWORK( * )
312 REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
313 $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
314 $ WORK( * )
315* ..
316*
317* =====================================================================
318* Replaced various illegal calls to SCOPY by calls to SLASET.
319* Sven Hammarling, 1/5/02.
320*
321* .. Parameters ..
322 REAL ZERO, ONE
323 parameter( zero = 0.0e+0, one = 1.0e+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 REAL DSCALE, DSUM, SCALE2, SCALOC
330* ..
331* .. External Functions ..
332 LOGICAL LSAME
333 INTEGER ILAENV
334 EXTERNAL lsame, ilaenv
335* ..
336* .. External Subroutines ..
337 EXTERNAL sgemm, slacpy, slaset, sscal, stgsy2, xerbla
338* ..
339* .. Intrinsic Functions ..
340 INTRINSIC max, real, 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( 'STGSYL', -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, 'STGSYL', trans, m, n, -1, -1 )
416 nb = ilaenv( 5, 'STGSYL', 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 slaset( 'F', m, n, zero, zero, c, ldc )
424 CALL slaset( 'F', m, n, zero, zero, f, ldf )
425 ELSE IF( ijob.GE.1 .AND. notran ) 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 stgsy2( 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( real( 2*m*n ) ) / ( dscale*sqrt( dsum ) )
446 ELSE
447 dif = sqrt( real( 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 slacpy( 'F', m, n, c, ldc, work, m )
457 CALL slacpy( 'F', m, n, f, ldf, work( m*n+1 ), m )
458 CALL slaset( 'F', m, n, zero, zero, c, ldc )
459 CALL slaset( 'F', m, n, zero, zero, f, ldf )
460 ELSE IF( isolve.EQ.2 .AND. iround.EQ.2 ) THEN
461 CALL slacpy( 'F', m, n, work, m, c, ldc )
462 CALL slacpy( '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 stgsy2( 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 sscal( m, scaloc, c( 1, k ), 1 )
546 CALL sscal( m, scaloc, f( 1, k ), 1 )
547 80 CONTINUE
548 DO 90 k = js, je
549 CALL sscal( is-1, scaloc, c( 1, k ), 1 )
550 CALL sscal( is-1, scaloc, f( 1, k ), 1 )
551 90 CONTINUE
552 DO 100 k = js, je
553 CALL sscal( m-ie, scaloc, c( ie+1, k ), 1 )
554 CALL sscal( m-ie, scaloc, f( ie+1, k ), 1 )
555 100 CONTINUE
556 DO 110 k = je + 1, n
557 CALL sscal( m, scaloc, c( 1, k ), 1 )
558 CALL sscal( 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 sgemm( 'N', 'N', is-1, nb, mb, -one,
568 $ a( 1, is ), lda, c( is, js ), ldc, one,
569 $ c( 1, js ), ldc )
570 CALL sgemm( '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 sgemm( '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 sgemm( '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( real( 2*m*n ) ) / ( dscale*sqrt( dsum ) )
587 ELSE
588 dif = sqrt( real( 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 slacpy( 'F', m, n, c, ldc, work, m )
597 CALL slacpy( 'F', m, n, f, ldf, work( m*n+1 ), m )
598 CALL slaset( 'F', m, n, zero, zero, c, ldc )
599 CALL slaset( 'F', m, n, zero, zero, f, ldf )
600 ELSE IF( isolve.EQ.2 .AND. iround.EQ.2 ) THEN
601 CALL slacpy( 'F', m, n, work, m, c, ldc )
602 CALL slacpy( '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 stgsy2( 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 sscal( m, scaloc, c( 1, k ), 1 )
633 CALL sscal( m, scaloc, f( 1, k ), 1 )
634 160 CONTINUE
635 DO 170 k = js, je
636 CALL sscal( is-1, scaloc, c( 1, k ), 1 )
637 CALL sscal( is-1, scaloc, f( 1, k ), 1 )
638 170 CONTINUE
639 DO 180 k = js, je
640 CALL sscal( m-ie, scaloc, c( ie+1, k ), 1 )
641 CALL sscal( m-ie, scaloc, f( ie+1, k ), 1 )
642 180 CONTINUE
643 DO 190 k = je + 1, n
644 CALL sscal( m, scaloc, c( 1, k ), 1 )
645 CALL sscal( 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 sgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),
654 $ ldc, b( 1, js ), ldb, one, f( is, 1 ),
655 $ ldf )
656 CALL sgemm( '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 sgemm( '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 sgemm( '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 STGSYL
678*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
stgsy2
subroutine stgsy2(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, rdsum, rdscal, iwork, pq, info)
STGSY2 solves the generalized Sylvester equation (unblocked algorithm).
Definition stgsy2.f:274

◆ strsyl()

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

STRSYL

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

Purpose:
!>
!> STRSYL 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 SHSEQR), 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 REAL 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 REAL 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 REAL array, dimension (LDC,N)
!>          On entry, the M-by-N right hand side matrix C.
!>          On exit, C is overwritten by the solution matrix X.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M)
!>
[out]SCALE
!>          SCALE is REAL
!>          The scale factor, scale, set <= 1 to avoid overflow in X.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1: A and B have common or very close eigenvalues; perturbed
!>               values were used to solve the equation (but the matrices
!>               A and B are unchanged).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 162 of file strsyl.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 REAL SCALE
173* ..
174* .. Array Arguments ..
175 REAL A( LDA, * ), B( LDB, * ), C( LDC, * )
176* ..
177*
178* =====================================================================
179*
180* .. Parameters ..
181 REAL ZERO, ONE
182 parameter( zero = 0.0e+0, one = 1.0e+0 )
183* ..
184* .. Local Scalars ..
185 LOGICAL NOTRNA, NOTRNB
186 INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
187 REAL A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
188 $ SMLNUM, SUML, SUMR, XNORM
189* ..
190* .. Local Arrays ..
191 REAL DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
192* ..
193* .. External Functions ..
194 LOGICAL LSAME
195 REAL SDOT, SLAMCH, SLANGE
196 EXTERNAL lsame, sdot, slamch, slange
197* ..
198* .. External Subroutines ..
199 EXTERNAL slabad, slaln2, slasy2, sscal, xerbla
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC abs, max, min, real
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( 'STRSYL', -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 = slamch( 'P' )
245 smlnum = slamch( 'S' )
246 bignum = one / smlnum
247 CALL slabad( smlnum, bignum )
248 smlnum = smlnum*real( m*n ) / eps
249 bignum = one / smlnum
250*
251 smin = max( smlnum, eps*slange( 'M', m, m, a, lda, dum ),
252 $ eps*slange( '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 70 l = 1, n
275 IF( l.LT.lnext )
276 $ GO TO 70
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 60 k = m, 1, -1
297 IF( k.GT.knext )
298 $ GO TO 60
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 = sdot( m-k1, a( k1, min( k1+1, m ) ), lda,
316 $ c( min( k1+1, m ), l1 ), 1 )
317 sumr = sdot( 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 sscal( 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 = sdot( m-k2, a( k1, min( k2+1, m ) ), lda,
346 $ c( min( k2+1, m ), l1 ), 1 )
347 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
348 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
349*
350 suml = sdot( m-k2, a( k2, min( k2+1, m ) ), lda,
351 $ c( min( k2+1, m ), l1 ), 1 )
352 sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
353 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
354*
355 CALL slaln2( .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 sscal( 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 = sdot( m-k1, a( k1, min( k1+1, m ) ), lda,
373 $ c( min( k1+1, m ), l1 ), 1 )
374 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
375 vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
376*
377 suml = sdot( m-k1, a( k1, min( k1+1, m ) ), lda,
378 $ c( min( k1+1, m ), l2 ), 1 )
379 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
380 vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
381*
382 CALL slaln2( .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 40 j = 1, n
390 CALL sscal( m, scaloc, c( 1, j ), 1 )
391 40 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 = sdot( m-k2, a( k1, min( k2+1, m ) ), lda,
400 $ c( min( k2+1, m ), l1 ), 1 )
401 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
402 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
403*
404 suml = sdot( m-k2, a( k1, min( k2+1, m ) ), lda,
405 $ c( min( k2+1, m ), l2 ), 1 )
406 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
407 vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr )
408*
409 suml = sdot( m-k2, a( k2, min( k2+1, m ) ), lda,
410 $ c( min( k2+1, m ), l1 ), 1 )
411 sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
412 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
413*
414 suml = sdot( m-k2, a( k2, min( k2+1, m ) ), lda,
415 $ c( min( k2+1, m ), l2 ), 1 )
416 sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 )
417 vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr )
418*
419 CALL slasy2( .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 50 j = 1, n
427 CALL sscal( m, scaloc, c( 1, j ), 1 )
428 50 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 60 CONTINUE
438*
439 70 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 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 130 l = 1, n
460 IF( l.LT.lnext )
461 $ GO TO 130
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 120 k = 1, m
482 IF( k.LT.knext )
483 $ GO TO 120
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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
501 sumr = sdot( 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 80 j = 1, n
521 CALL sscal( m, scaloc, c( 1, j ), 1 )
522 80 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
530 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
531 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
532*
533 suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
534 sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
535 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
536*
537 CALL slaln2( .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 90 j = 1, n
545 CALL sscal( m, scaloc, c( 1, j ), 1 )
546 90 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
555 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
556 vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
557*
558 suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
559 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
560 vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
561*
562 CALL slaln2( .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 100 j = 1, n
570 CALL sscal( m, scaloc, c( 1, j ), 1 )
571 100 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
580 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 )
581 vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr )
582*
583 suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
584 sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 )
585 vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr )
586*
587 suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
588 sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 )
589 vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr )
590*
591 suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 )
592 sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 )
593 vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr )
594*
595 CALL slasy2( .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 110 j = 1, n
603 CALL sscal( m, scaloc, c( 1, j ), 1 )
604 110 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 120 CONTINUE
614 130 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 190 l = n, 1, -1
635 IF( l.GT.lnext )
636 $ GO TO 190
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 180 k = 1, m
657 IF( k.LT.knext )
658 $ GO TO 180
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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
676 sumr = sdot( 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 140 j = 1, n
697 CALL sscal( m, scaloc, c( 1, j ), 1 )
698 140 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
706 sumr = sdot( 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 = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
711 sumr = sdot( 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 slaln2( .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 150 j = 1, n
723 CALL sscal( m, scaloc, c( 1, j ), 1 )
724 150 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
733 sumr = sdot( 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
738 sumr = sdot( 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 slaln2( .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 160 j = 1, n
750 CALL sscal( m, scaloc, c( 1, j ), 1 )
751 160 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 )
760 sumr = sdot( 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 = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 )
765 sumr = sdot( 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 = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 )
770 sumr = sdot( 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 = sdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 )
775 sumr = sdot( 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 slasy2( .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 170 j = 1, n
787 CALL sscal( m, scaloc, c( 1, j ), 1 )
788 170 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 180 CONTINUE
798 190 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 250 l = n, 1, -1
819 IF( l.GT.lnext )
820 $ GO TO 250
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 240 k = m, 1, -1
841 IF( k.GT.knext )
842 $ GO TO 240
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 = sdot( m-k1, a( k1, min(k1+1, m ) ), lda,
860 $ c( min( k1+1, m ), l1 ), 1 )
861 sumr = sdot( 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 200 j = 1, n
882 CALL sscal( m, scaloc, c( 1, j ), 1 )
883 200 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 = sdot( m-k2, a( k1, min( k2+1, m ) ), lda,
891 $ c( min( k2+1, m ), l1 ), 1 )
892 sumr = sdot( 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 = sdot( m-k2, a( k2, min( k2+1, m ) ), lda,
897 $ c( min( k2+1, m ), l1 ), 1 )
898 sumr = sdot( 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 slaln2( .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 210 j = 1, n
910 CALL sscal( m, scaloc, c( 1, j ), 1 )
911 210 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 = sdot( m-k1, a( k1, min( k1+1, m ) ), lda,
920 $ c( min( k1+1, m ), l1 ), 1 )
921 sumr = sdot( 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 = sdot( m-k1, a( k1, min( k1+1, m ) ), lda,
926 $ c( min( k1+1, m ), l2 ), 1 )
927 sumr = sdot( 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 slaln2( .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 220 j = 1, n
939 CALL sscal( m, scaloc, c( 1, j ), 1 )
940 220 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 = sdot( m-k2, a( k1, min( k2+1, m ) ), lda,
949 $ c( min( k2+1, m ), l1 ), 1 )
950 sumr = sdot( 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 = sdot( m-k2, a( k1, min( k2+1, m ) ), lda,
955 $ c( min( k2+1, m ), l2 ), 1 )
956 sumr = sdot( 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 = sdot( m-k2, a( k2, min( k2+1, m ) ), lda,
961 $ c( min( k2+1, m ), l1 ), 1 )
962 sumr = sdot( 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 = sdot( m-k2, a( k2, min( k2+1, m ) ), lda,
967 $ c( min( k2+1, m ), l2 ), 1 )
968 sumr = sdot( 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 slasy2( .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 230 j = 1, n
980 CALL sscal( m, scaloc, c( 1, j ), 1 )
981 230 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 240 CONTINUE
991 250 CONTINUE
992*
993 END IF
994*
995 RETURN
996*
997* End of STRSYL
998*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
slange
real function slange(norm, m, n, a, lda, work)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slange.f:114
slaln2
subroutine slaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
SLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition slaln2.f:218
slasy2
subroutine slasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
SLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition slasy2.f:174