OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
real
LAPACK » General Matrices » Computational routines

Functions

subroutine sgeqpf (m, n, a, lda, jpvt, tau, work, info)
 SGEQPF
subroutine sgebak (job, side, n, ilo, ihi, scale, m, v, ldv, info)
 SGEBAK
subroutine sgebal (job, n, a, lda, ilo, ihi, scale, info)
 SGEBAL
subroutine sgebd2 (m, n, a, lda, d, e, tauq, taup, work, info)
 SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine sgebrd (m, n, a, lda, d, e, tauq, taup, work, lwork, info)
 SGEBRD
subroutine sgecon (norm, n, a, lda, anorm, rcond, work, iwork, info)
 SGECON
subroutine sgeequ (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 SGEEQU
subroutine sgeequb (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 SGEEQUB
subroutine sgehd2 (n, ilo, ihi, a, lda, tau, work, info)
 SGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
subroutine sgehrd (n, ilo, ihi, a, lda, tau, work, lwork, info)
 SGEHRD
subroutine sgelq2 (m, n, a, lda, tau, work, info)
 SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine sgelqf (m, n, a, lda, tau, work, lwork, info)
 SGELQF
subroutine sgemqrt (side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
 SGEMQRT
subroutine sgeql2 (m, n, a, lda, tau, work, info)
 SGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
subroutine sgeqlf (m, n, a, lda, tau, work, lwork, info)
 SGEQLF
subroutine sgeqp3 (m, n, a, lda, jpvt, tau, work, lwork, info)
 SGEQP3
subroutine sgeqr2 (m, n, a, lda, tau, work, info)
 SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
subroutine sgeqr2p (m, n, a, lda, tau, work, info)
 SGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm.
subroutine sgeqrf (m, n, a, lda, tau, work, lwork, info)
 SGEQRF
subroutine sgeqrfp (m, n, a, lda, tau, work, lwork, info)
 SGEQRFP
subroutine sgeqrt (m, n, nb, a, lda, t, ldt, work, info)
 SGEQRT
subroutine sgeqrt2 (m, n, a, lda, t, ldt, info)
 SGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
recursive subroutine sgeqrt3 (m, n, a, lda, t, ldt, info)
 SGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
subroutine sgerfs (trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 SGERFS
subroutine sgerfsx (trans, equed, n, nrhs, a, lda, af, ldaf, ipiv, r, c, b, ldb, x, ldx, rcond, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, iwork, info)
 SGERFSX
subroutine sgerq2 (m, n, a, lda, tau, work, info)
 SGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine sgerqf (m, n, a, lda, tau, work, lwork, info)
 SGERQF
subroutine sgesvj (joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, work, lwork, info)
 SGESVJ
subroutine sgetf2 (m, n, a, lda, ipiv, info)
 SGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
subroutine sgetrf (m, n, a, lda, ipiv, info)
 SGETRF
recursive subroutine sgetrf2 (m, n, a, lda, ipiv, info)
 SGETRF2
subroutine sgetri (n, a, lda, ipiv, work, lwork, info)
 SGETRI
subroutine sgetrs (trans, n, nrhs, a, lda, ipiv, b, ldb, info)
 SGETRS
subroutine shgeqz (job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, info)
 SHGEQZ
subroutine sla_geamv (trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
 SLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.
real function sla_gercond (trans, n, a, lda, af, ldaf, ipiv, cmode, c, info, work, iwork)
 SLA_GERCOND estimates the Skeel condition number for a general matrix.
subroutine sla_gerfsx_extended (prec_type, trans_type, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
 SLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.
real function sla_gerpvgrw (n, ncols, a, lda, af, ldaf)
 SLA_GERPVGRW
subroutine slaorhr_col_getrfnp (m, n, a, lda, d, info)
 SLAORHR_COL_GETRFNP
recursive subroutine slaorhr_col_getrfnp2 (m, n, a, lda, d, info)
 SLAORHR_COL_GETRFNP2
subroutine stgevc (side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, info)
 STGEVC
subroutine stgexc (wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
 STGEXC

Detailed Description

This is the group of real computational functions for GE matrices

Function Documentation

◆ sgebak()

subroutine sgebak ( character job,
character side,
integer n,
integer ilo,
integer ihi,
real, dimension( * ) scale,
integer m,
real, dimension( ldv, * ) v,
integer ldv,
integer info )

SGEBAK

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

Purpose:
!>
!> SGEBAK forms the right or left eigenvectors of a real general matrix
!> by backward transformation on the computed eigenvectors of the
!> balanced matrix output by SGEBAL.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies the type of backward transformation required:
!>          = 'N': do nothing, return immediately;
!>          = 'P': do backward transformation for permutation only;
!>          = 'S': do backward transformation for scaling only;
!>          = 'B': do backward transformations for both permutation and
!>                 scaling.
!>          JOB must be the same as the argument JOB supplied to SGEBAL.
!>
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'R':  V contains right eigenvectors;
!>          = 'L':  V contains left eigenvectors.
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrix V.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          The integers ILO and IHI determined by SGEBAL.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in]SCALE
!>          SCALE is REAL array, dimension (N)
!>          Details of the permutation and scaling factors, as returned
!>          by SGEBAL.
!>
[in]M
!>          M is INTEGER
!>          The number of columns of the matrix V.  M >= 0.
!>
[in,out]V
!>          V is REAL array, dimension (LDV,M)
!>          On entry, the matrix of right or left eigenvectors to be
!>          transformed, as returned by SHSEIN or STREVC.
!>          On exit, V is overwritten by the transformed eigenvectors.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= 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 128 of file sgebak.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 JOB, SIDE
137 INTEGER IHI, ILO, INFO, LDV, M, N
138* ..
139* .. Array Arguments ..
140 REAL V( LDV, * ), SCALE( * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 REAL ONE
147 parameter( one = 1.0e+0 )
148* ..
149* .. Local Scalars ..
150 LOGICAL LEFTV, RIGHTV
151 INTEGER I, II, K
152 REAL S
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 EXTERNAL lsame
157* ..
158* .. External Subroutines ..
159 EXTERNAL sscal, sswap, xerbla
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max, min
163* ..
164* .. Executable Statements ..
165*
166* Decode and Test the input parameters
167*
168 rightv = lsame( side, 'R' )
169 leftv = lsame( side, 'L' )
170*
171 info = 0
172 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
173 $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
174 info = -1
175 ELSE IF( .NOT.rightv .AND. .NOT.leftv ) THEN
176 info = -2
177 ELSE IF( n.LT.0 ) THEN
178 info = -3
179 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
180 info = -4
181 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
182 info = -5
183 ELSE IF( m.LT.0 ) THEN
184 info = -7
185 ELSE IF( ldv.LT.max( 1, n ) ) THEN
186 info = -9
187 END IF
188 IF( info.NE.0 ) THEN
189 CALL xerbla( 'SGEBAK', -info )
190 RETURN
191 END IF
192*
193* Quick return if possible
194*
195 IF( n.EQ.0 )
196 $ RETURN
197 IF( m.EQ.0 )
198 $ RETURN
199 IF( lsame( job, 'N' ) )
200 $ RETURN
201*
202 IF( ilo.EQ.ihi )
203 $ GO TO 30
204*
205* Backward balance
206*
207 IF( lsame( job, 'S' ) .OR. lsame( job, 'B' ) ) THEN
208*
209 IF( rightv ) THEN
210 DO 10 i = ilo, ihi
211 s = scale( i )
212 CALL sscal( m, s, v( i, 1 ), ldv )
213 10 CONTINUE
214 END IF
215*
216 IF( leftv ) THEN
217 DO 20 i = ilo, ihi
218 s = one / scale( i )
219 CALL sscal( m, s, v( i, 1 ), ldv )
220 20 CONTINUE
221 END IF
222*
223 END IF
224*
225* Backward permutation
226*
227* For I = ILO-1 step -1 until 1,
228* IHI+1 step 1 until N do --
229*
230 30 CONTINUE
231 IF( lsame( job, 'P' ) .OR. lsame( job, 'B' ) ) THEN
232 IF( rightv ) THEN
233 DO 40 ii = 1, n
234 i = ii
235 IF( i.GE.ilo .AND. i.LE.ihi )
236 $ GO TO 40
237 IF( i.LT.ilo )
238 $ i = ilo - ii
239 k = scale( i )
240 IF( k.EQ.i )
241 $ GO TO 40
242 CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv )
243 40 CONTINUE
244 END IF
245*
246 IF( leftv ) THEN
247 DO 50 ii = 1, n
248 i = ii
249 IF( i.GE.ilo .AND. i.LE.ihi )
250 $ GO TO 50
251 IF( i.LT.ilo )
252 $ i = ilo - ii
253 k = scale( i )
254 IF( k.EQ.i )
255 $ GO TO 50
256 CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv )
257 50 CONTINUE
258 END IF
259 END IF
260*
261 RETURN
262*
263* End of SGEBAK
264*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
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
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ sgebal()

subroutine sgebal ( character job,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer ilo,
integer ihi,
real, dimension( * ) scale,
integer info )

SGEBAL

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

Purpose:
!>
!> SGEBAL balances a general real matrix A.  This involves, first,
!> permuting A by a similarity transformation to isolate eigenvalues
!> in the first 1 to ILO-1 and last IHI+1 to N elements on the
!> diagonal; and second, applying a diagonal similarity transformation
!> to rows and columns ILO to IHI to make the rows and columns as
!> close in norm as possible.  Both steps are optional.
!>
!> Balancing may reduce the 1-norm of the matrix, and improve the
!> accuracy of the computed eigenvalues and/or eigenvectors.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies the operations to be performed on A:
!>          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
!>                  for i = 1,...,N;
!>          = 'P':  permute only;
!>          = 'S':  scale only;
!>          = 'B':  both permute and scale.
!>
[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 input matrix A.
!>          On exit,  A is overwritten by the balanced matrix.
!>          If JOB = 'N', A is not referenced.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]ILO
!>          ILO is INTEGER
!>
[out]IHI
!>          IHI is INTEGER
!>          ILO and IHI are set to integers such that on exit
!>          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
!>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!>
[out]SCALE
!>          SCALE is REAL array, dimension (N)
!>          Details of the permutations and scaling factors applied to
!>          A.  If P(j) is the index of the row and column interchanged
!>          with row and column j and D(j) is the scaling factor
!>          applied to row and column j, then
!>          SCALE(j) = P(j)    for j = 1,...,ILO-1
!>                   = D(j)    for j = ILO,...,IHI
!>                   = P(j)    for j = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-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:
!>
!>  The permutations consist of row and column interchanges which put
!>  the matrix in the form
!>
!>             ( T1   X   Y  )
!>     P A P = (  0   B   Z  )
!>             (  0   0   T2 )
!>
!>  where T1 and T2 are upper triangular matrices whose eigenvalues lie
!>  along the diagonal.  The column indices ILO and IHI mark the starting
!>  and ending columns of the submatrix B. Balancing consists of applying
!>  a diagonal similarity transformation inv(D) * B * D to make the
!>  1-norms of each row of B and its corresponding column nearly equal.
!>  The output matrix is
!>
!>     ( T1     X*D          Y    )
!>     (  0  inv(D)*B*D  inv(D)*Z ).
!>     (  0      0           T2   )
!>
!>  Information about the permutations P and the diagonal matrix D is
!>  returned in the vector SCALE.
!>
!>  This subroutine is based on the EISPACK routine BALANC.
!>
!>  Modified by Tzu-Yi Chen, Computer Science Division, University of
!>    California at Berkeley, USA
!>

Definition at line 159 of file sgebal.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* .. Scalar Arguments ..
166 CHARACTER JOB
167 INTEGER IHI, ILO, INFO, LDA, N
168* ..
169* .. Array Arguments ..
170 REAL A( LDA, * ), SCALE( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 REAL ZERO, ONE
177 parameter( zero = 0.0e+0, one = 1.0e+0 )
178 REAL SCLFAC
179 parameter( sclfac = 2.0e+0 )
180 REAL FACTOR
181 parameter( factor = 0.95e+0 )
182* ..
183* .. Local Scalars ..
184 LOGICAL NOCONV
185 INTEGER I, ICA, IEXC, IRA, J, K, L, M
186 REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
187 $ SFMIN2
188* ..
189* .. External Functions ..
190 LOGICAL SISNAN, LSAME
191 INTEGER ISAMAX
192 REAL SLAMCH, SNRM2
193 EXTERNAL sisnan, lsame, isamax, slamch, snrm2
194* ..
195* .. External Subroutines ..
196 EXTERNAL sscal, sswap, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, max, min
200*
201* Test the input parameters
202*
203 info = 0
204 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
205 $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
206 info = -1
207 ELSE IF( n.LT.0 ) THEN
208 info = -2
209 ELSE IF( lda.LT.max( 1, n ) ) THEN
210 info = -4
211 END IF
212 IF( info.NE.0 ) THEN
213 CALL xerbla( 'SGEBAL', -info )
214 RETURN
215 END IF
216*
217 k = 1
218 l = n
219*
220 IF( n.EQ.0 )
221 $ GO TO 210
222*
223 IF( lsame( job, 'N' ) ) THEN
224 DO 10 i = 1, n
225 scale( i ) = one
226 10 CONTINUE
227 GO TO 210
228 END IF
229*
230 IF( lsame( job, 'S' ) )
231 $ GO TO 120
232*
233* Permutation to isolate eigenvalues if possible
234*
235 GO TO 50
236*
237* Row and column exchange.
238*
239 20 CONTINUE
240 scale( m ) = j
241 IF( j.EQ.m )
242 $ GO TO 30
243*
244 CALL sswap( l, a( 1, j ), 1, a( 1, m ), 1 )
245 CALL sswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
246*
247 30 CONTINUE
248 GO TO ( 40, 80 )iexc
249*
250* Search for rows isolating an eigenvalue and push them down.
251*
252 40 CONTINUE
253 IF( l.EQ.1 )
254 $ GO TO 210
255 l = l - 1
256*
257 50 CONTINUE
258 DO 70 j = l, 1, -1
259*
260 DO 60 i = 1, l
261 IF( i.EQ.j )
262 $ GO TO 60
263 IF( a( j, i ).NE.zero )
264 $ GO TO 70
265 60 CONTINUE
266*
267 m = l
268 iexc = 1
269 GO TO 20
270 70 CONTINUE
271*
272 GO TO 90
273*
274* Search for columns isolating an eigenvalue and push them left.
275*
276 80 CONTINUE
277 k = k + 1
278*
279 90 CONTINUE
280 DO 110 j = k, l
281*
282 DO 100 i = k, l
283 IF( i.EQ.j )
284 $ GO TO 100
285 IF( a( i, j ).NE.zero )
286 $ GO TO 110
287 100 CONTINUE
288*
289 m = k
290 iexc = 2
291 GO TO 20
292 110 CONTINUE
293*
294 120 CONTINUE
295 DO 130 i = k, l
296 scale( i ) = one
297 130 CONTINUE
298*
299 IF( lsame( job, 'P' ) )
300 $ GO TO 210
301*
302* Balance the submatrix in rows K to L.
303*
304* Iterative loop for norm reduction
305*
306 sfmin1 = slamch( 'S' ) / slamch( 'P' )
307 sfmax1 = one / sfmin1
308 sfmin2 = sfmin1*sclfac
309 sfmax2 = one / sfmin2
310 140 CONTINUE
311 noconv = .false.
312*
313 DO 200 i = k, l
314*
315 c = snrm2( l-k+1, a( k, i ), 1 )
316 r = snrm2( l-k+1, a( i, k ), lda )
317 ica = isamax( l, a( 1, i ), 1 )
318 ca = abs( a( ica, i ) )
319 ira = isamax( n-k+1, a( i, k ), lda )
320 ra = abs( a( i, ira+k-1 ) )
321*
322* Guard against zero C or R due to underflow.
323*
324 IF( c.EQ.zero .OR. r.EQ.zero )
325 $ GO TO 200
326 g = r / sclfac
327 f = one
328 s = c + r
329 160 CONTINUE
330 IF( c.GE.g .OR. max( f, c, ca ).GE.sfmax2 .OR.
331 $ min( r, g, ra ).LE.sfmin2 )GO TO 170
332 f = f*sclfac
333 c = c*sclfac
334 ca = ca*sclfac
335 r = r / sclfac
336 g = g / sclfac
337 ra = ra / sclfac
338 GO TO 160
339*
340 170 CONTINUE
341 g = c / sclfac
342 180 CONTINUE
343 IF( g.LT.r .OR. max( r, ra ).GE.sfmax2 .OR.
344 $ min( f, c, g, ca ).LE.sfmin2 )GO TO 190
345 IF( sisnan( c+f+ca+r+g+ra ) ) THEN
346*
347* Exit if NaN to avoid infinite loop
348*
349 info = -3
350 CALL xerbla( 'SGEBAL', -info )
351 RETURN
352 END IF
353 f = f / sclfac
354 c = c / sclfac
355 g = g / sclfac
356 ca = ca / sclfac
357 r = r*sclfac
358 ra = ra*sclfac
359 GO TO 180
360*
361* Now balance.
362*
363 190 CONTINUE
364 IF( ( c+r ).GE.factor*s )
365 $ GO TO 200
366 IF( f.LT.one .AND. scale( i ).LT.one ) THEN
367 IF( f*scale( i ).LE.sfmin1 )
368 $ GO TO 200
369 END IF
370 IF( f.GT.one .AND. scale( i ).GT.one ) THEN
371 IF( scale( i ).GE.sfmax1 / f )
372 $ GO TO 200
373 END IF
374 g = one / f
375 scale( i ) = scale( i )*f
376 noconv = .true.
377*
378 CALL sscal( n-k+1, g, a( i, k ), lda )
379 CALL sscal( l, f, a( 1, i ), 1 )
380*
381 200 CONTINUE
382*
383 IF( noconv )
384 $ GO TO 140
385*
386 210 CONTINUE
387 ilo = k
388 ihi = l
389*
390 RETURN
391*
392* End of SGEBAL
393*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ sgebd2()

subroutine sgebd2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( * ) tauq,
real, dimension( * ) taup,
real, dimension( * ) work,
integer info )

SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.

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

Purpose:
!>
!> SGEBD2 reduces a real general m by n matrix A to upper or lower
!> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
!>
!> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n general matrix to be reduced.
!>          On exit,
!>          if m >= n, the diagonal and the first superdiagonal are
!>            overwritten with the upper bidiagonal matrix B; the
!>            elements below the diagonal, with the array TAUQ, represent
!>            the orthogonal matrix Q as a product of elementary
!>            reflectors, and the elements above the first superdiagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors;
!>          if m < n, the diagonal and the first subdiagonal are
!>            overwritten with the lower bidiagonal matrix B; the
!>            elements below the first subdiagonal, with the array TAUQ,
!>            represent the orthogonal matrix Q as a product of
!>            elementary reflectors, and the elements above the diagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is REAL array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL array, dimension (min(M,N)-1)
!>          The off-diagonal elements of the bidiagonal matrix B:
!>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!>
[out]TAUQ
!>          TAUQ is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix P. See Further Details.
!>
[out]WORK
!>          WORK is REAL array, dimension (max(M,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.
Further Details:
!>
!>  The matrices Q and P are represented as products of elementary
!>  reflectors:
!>
!>  If m >= n,
!>
!>     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
!>  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  If m < n,
!>
!>     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
!>  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  The contents of A on exit are illustrated by the following examples:
!>
!>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!>
!>    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
!>    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
!>    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
!>    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
!>    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
!>    (  v1  v2  v3  v4  v5 )
!>
!>  where d and e denote diagonal and off-diagonal elements of B, vi
!>  denotes an element of the vector defining H(i), and ui an element of
!>  the vector defining G(i).
!>

Definition at line 188 of file sgebd2.f.

189*
190* -- LAPACK computational routine --
191* -- LAPACK is a software package provided by Univ. of Tennessee, --
192* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
193*
194* .. Scalar Arguments ..
195 INTEGER INFO, LDA, M, N
196* ..
197* .. Array Arguments ..
198 REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
199 $ TAUQ( * ), WORK( * )
200* ..
201*
202* =====================================================================
203*
204* .. Parameters ..
205 REAL ZERO, ONE
206 parameter( zero = 0.0e+0, one = 1.0e+0 )
207* ..
208* .. Local Scalars ..
209 INTEGER I
210* ..
211* .. External Subroutines ..
212 EXTERNAL slarf, slarfg, xerbla
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC max, min
216* ..
217* .. Executable Statements ..
218*
219* Test the input parameters
220*
221 info = 0
222 IF( m.LT.0 ) THEN
223 info = -1
224 ELSE IF( n.LT.0 ) THEN
225 info = -2
226 ELSE IF( lda.LT.max( 1, m ) ) THEN
227 info = -4
228 END IF
229 IF( info.LT.0 ) THEN
230 CALL xerbla( 'SGEBD2', -info )
231 RETURN
232 END IF
233*
234 IF( m.GE.n ) THEN
235*
236* Reduce to upper bidiagonal form
237*
238 DO 10 i = 1, n
239*
240* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
241*
242 CALL slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
243 $ tauq( i ) )
244 d( i ) = a( i, i )
245 a( i, i ) = one
246*
247* Apply H(i) to A(i:m,i+1:n) from the left
248*
249 IF( i.LT.n )
250 $ CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tauq( i ),
251 $ a( i, i+1 ), lda, work )
252 a( i, i ) = d( i )
253*
254 IF( i.LT.n ) THEN
255*
256* Generate elementary reflector G(i) to annihilate
257* A(i,i+2:n)
258*
259 CALL slarfg( n-i, a( i, i+1 ), a( i, min( i+2, n ) ),
260 $ lda, taup( i ) )
261 e( i ) = a( i, i+1 )
262 a( i, i+1 ) = one
263*
264* Apply G(i) to A(i+1:m,i+1:n) from the right
265*
266 CALL slarf( 'Right', m-i, n-i, a( i, i+1 ), lda,
267 $ taup( i ), a( i+1, i+1 ), lda, work )
268 a( i, i+1 ) = e( i )
269 ELSE
270 taup( i ) = zero
271 END IF
272 10 CONTINUE
273 ELSE
274*
275* Reduce to lower bidiagonal form
276*
277 DO 20 i = 1, m
278*
279* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
280*
281 CALL slarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,
282 $ taup( i ) )
283 d( i ) = a( i, i )
284 a( i, i ) = one
285*
286* Apply G(i) to A(i+1:m,i:n) from the right
287*
288 IF( i.LT.m )
289 $ CALL slarf( 'Right', m-i, n-i+1, a( i, i ), lda,
290 $ taup( i ), a( i+1, i ), lda, work )
291 a( i, i ) = d( i )
292*
293 IF( i.LT.m ) THEN
294*
295* Generate elementary reflector H(i) to annihilate
296* A(i+2:m,i)
297*
298 CALL slarfg( m-i, a( i+1, i ), a( min( i+2, m ), i ), 1,
299 $ tauq( i ) )
300 e( i ) = a( i+1, i )
301 a( i+1, i ) = one
302*
303* Apply H(i) to A(i+1:m,i+1:n) from the left
304*
305 CALL slarf( 'Left', m-i, n-i, a( i+1, i ), 1, tauq( i ),
306 $ a( i+1, i+1 ), lda, work )
307 a( i+1, i ) = e( i )
308 ELSE
309 tauq( i ) = zero
310 END IF
311 20 CONTINUE
312 END IF
313 RETURN
314*
315* End of SGEBD2
316*
slarf
subroutine slarf(side, m, n, v, incv, tau, c, ldc, work)
SLARF applies an elementary reflector to a general rectangular matrix.
Definition slarf.f:124
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106

◆ sgebrd()

subroutine sgebrd ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( * ) tauq,
real, dimension( * ) taup,
real, dimension( * ) work,
integer lwork,
integer info )

SGEBRD

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

Purpose:
!>
!> SGEBRD reduces a general real M-by-N matrix A to upper or lower
!> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
!>
!> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N general matrix to be reduced.
!>          On exit,
!>          if m >= n, the diagonal and the first superdiagonal are
!>            overwritten with the upper bidiagonal matrix B; the
!>            elements below the diagonal, with the array TAUQ, represent
!>            the orthogonal matrix Q as a product of elementary
!>            reflectors, and the elements above the first superdiagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors;
!>          if m < n, the diagonal and the first subdiagonal are
!>            overwritten with the lower bidiagonal matrix B; the
!>            elements below the first subdiagonal, with the array TAUQ,
!>            represent the orthogonal matrix Q as a product of
!>            elementary reflectors, and the elements above the diagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is REAL array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL array, dimension (min(M,N)-1)
!>          The off-diagonal elements of the bidiagonal matrix B:
!>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!>
[out]TAUQ
!>          TAUQ is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix P. 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 length of the array WORK.  LWORK >= max(1,M,N).
!>          For optimum performance LWORK >= (M+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:
!>
!>  The matrices Q and P are represented as products of elementary
!>  reflectors:
!>
!>  If m >= n,
!>
!>     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
!>  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  If m < n,
!>
!>     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
!>  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  The contents of A on exit are illustrated by the following examples:
!>
!>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!>
!>    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
!>    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
!>    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
!>    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
!>    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
!>    (  v1  v2  v3  v4  v5 )
!>
!>  where d and e denote diagonal and off-diagonal elements of B, vi
!>  denotes an element of the vector defining H(i), and ui an element of
!>  the vector defining G(i).
!>

Definition at line 203 of file sgebrd.f.

205*
206* -- LAPACK computational routine --
207* -- LAPACK is a software package provided by Univ. of Tennessee, --
208* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
209*
210* .. Scalar Arguments ..
211 INTEGER INFO, LDA, LWORK, M, N
212* ..
213* .. Array Arguments ..
214 REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
215 $ TAUQ( * ), WORK( * )
216* ..
217*
218* =====================================================================
219*
220* .. Parameters ..
221 REAL ONE
222 parameter( one = 1.0e+0 )
223* ..
224* .. Local Scalars ..
225 LOGICAL LQUERY
226 INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
227 $ NBMIN, NX, WS
228* ..
229* .. External Subroutines ..
230 EXTERNAL sgebd2, sgemm, slabrd, xerbla
231* ..
232* .. Intrinsic Functions ..
233 INTRINSIC max, min, real
234* ..
235* .. External Functions ..
236 INTEGER ILAENV
237 EXTERNAL ilaenv
238* ..
239* .. Executable Statements ..
240*
241* Test the input parameters
242*
243 info = 0
244 nb = max( 1, ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) )
245 lwkopt = ( m+n )*nb
246 work( 1 ) = real( lwkopt )
247 lquery = ( lwork.EQ.-1 )
248 IF( m.LT.0 ) THEN
249 info = -1
250 ELSE IF( n.LT.0 ) THEN
251 info = -2
252 ELSE IF( lda.LT.max( 1, m ) ) THEN
253 info = -4
254 ELSE IF( lwork.LT.max( 1, m, n ) .AND. .NOT.lquery ) THEN
255 info = -10
256 END IF
257 IF( info.LT.0 ) THEN
258 CALL xerbla( 'SGEBRD', -info )
259 RETURN
260 ELSE IF( lquery ) THEN
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 minmn = min( m, n )
267 IF( minmn.EQ.0 ) THEN
268 work( 1 ) = 1
269 RETURN
270 END IF
271*
272 ws = max( m, n )
273 ldwrkx = m
274 ldwrky = n
275*
276 IF( nb.GT.1 .AND. nb.LT.minmn ) THEN
277*
278* Set the crossover point NX.
279*
280 nx = max( nb, ilaenv( 3, 'SGEBRD', ' ', m, n, -1, -1 ) )
281*
282* Determine when to switch from blocked to unblocked code.
283*
284 IF( nx.LT.minmn ) THEN
285 ws = ( m+n )*nb
286 IF( lwork.LT.ws ) THEN
287*
288* Not enough work space for the optimal NB, consider using
289* a smaller block size.
290*
291 nbmin = ilaenv( 2, 'SGEBRD', ' ', m, n, -1, -1 )
292 IF( lwork.GE.( m+n )*nbmin ) THEN
293 nb = lwork / ( m+n )
294 ELSE
295 nb = 1
296 nx = minmn
297 END IF
298 END IF
299 END IF
300 ELSE
301 nx = minmn
302 END IF
303*
304 DO 30 i = 1, minmn - nx, nb
305*
306* Reduce rows and columns i:i+nb-1 to bidiagonal form and return
307* the matrices X and Y which are needed to update the unreduced
308* part of the matrix
309*
310 CALL slabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),
311 $ tauq( i ), taup( i ), work, ldwrkx,
312 $ work( ldwrkx*nb+1 ), ldwrky )
313*
314* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
315* of the form A := A - V*Y**T - X*U**T
316*
317 CALL sgemm( 'No transpose', 'Transpose', m-i-nb+1, n-i-nb+1,
318 $ nb, -one, a( i+nb, i ), lda,
319 $ work( ldwrkx*nb+nb+1 ), ldwrky, one,
320 $ a( i+nb, i+nb ), lda )
321 CALL sgemm( 'No transpose', 'No transpose', m-i-nb+1, n-i-nb+1,
322 $ nb, -one, work( nb+1 ), ldwrkx, a( i, i+nb ), lda,
323 $ one, a( i+nb, i+nb ), lda )
324*
325* Copy diagonal and off-diagonal elements of B back into A
326*
327 IF( m.GE.n ) THEN
328 DO 10 j = i, i + nb - 1
329 a( j, j ) = d( j )
330 a( j, j+1 ) = e( j )
331 10 CONTINUE
332 ELSE
333 DO 20 j = i, i + nb - 1
334 a( j, j ) = d( j )
335 a( j+1, j ) = e( j )
336 20 CONTINUE
337 END IF
338 30 CONTINUE
339*
340* Use unblocked code to reduce the remainder of the matrix
341*
342 CALL sgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),
343 $ tauq( i ), taup( i ), work, iinfo )
344 work( 1 ) = ws
345 RETURN
346*
347* End of SGEBRD
348*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
sgebd2
subroutine sgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition sgebd2.f:189
slabrd
subroutine slabrd(m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y, ldy)
SLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
Definition slabrd.f:210
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ sgecon()

subroutine sgecon ( character norm,
integer n,
real, dimension( lda, * ) a,
integer lda,
real anorm,
real rcond,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SGECON

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

Purpose:
!>
!> SGECON estimates the reciprocal of the condition number of a general
!> real matrix A, in either the 1-norm or the infinity-norm, using
!> the LU factorization computed by SGETRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as
!>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies whether the 1-norm condition number or the
!>          infinity-norm condition number is required:
!>          = '1' or 'O':  1-norm;
!>          = 'I':         Infinity-norm.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is REAL array, dimension (LDA,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by SGETRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]ANORM
!>          ANORM is REAL
!>          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!>          If NORM = 'I', the infinity-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/(norm(A) * norm(inv(A))).
!>
[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
!>          < 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 122 of file sgecon.f.

124*
125* -- LAPACK computational routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER NORM
131 INTEGER INFO, LDA, N
132 REAL ANORM, RCOND
133* ..
134* .. Array Arguments ..
135 INTEGER IWORK( * )
136 REAL A( LDA, * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ONE, ZERO
143 parameter( one = 1.0e+0, zero = 0.0e+0 )
144* ..
145* .. Local Scalars ..
146 LOGICAL ONENRM
147 CHARACTER NORMIN
148 INTEGER IX, KASE, KASE1
149 REAL AINVNM, SCALE, SL, SMLNUM, SU
150* ..
151* .. Local Arrays ..
152 INTEGER ISAVE( 3 )
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 INTEGER ISAMAX
157 REAL SLAMCH
158 EXTERNAL lsame, isamax, slamch
159* ..
160* .. External Subroutines ..
161 EXTERNAL slacn2, slatrs, srscl, xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC abs, max
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
172 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
173 info = -1
174 ELSE IF( n.LT.0 ) THEN
175 info = -2
176 ELSE IF( lda.LT.max( 1, n ) ) THEN
177 info = -4
178 ELSE IF( anorm.LT.zero ) THEN
179 info = -5
180 END IF
181 IF( info.NE.0 ) THEN
182 CALL xerbla( 'SGECON', -info )
183 RETURN
184 END IF
185*
186* Quick return if possible
187*
188 rcond = zero
189 IF( n.EQ.0 ) THEN
190 rcond = one
191 RETURN
192 ELSE IF( anorm.EQ.zero ) THEN
193 RETURN
194 END IF
195*
196 smlnum = slamch( 'Safe minimum' )
197*
198* Estimate the norm of inv(A).
199*
200 ainvnm = zero
201 normin = 'N'
202 IF( onenrm ) THEN
203 kase1 = 1
204 ELSE
205 kase1 = 2
206 END IF
207 kase = 0
208 10 CONTINUE
209 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
210 IF( kase.NE.0 ) THEN
211 IF( kase.EQ.kase1 ) THEN
212*
213* Multiply by inv(L).
214*
215 CALL slatrs( 'Lower', 'No transpose', 'Unit', normin, n, a,
216 $ lda, work, sl, work( 2*n+1 ), info )
217*
218* Multiply by inv(U).
219*
220 CALL slatrs( 'Upper', 'No transpose', 'Non-unit', normin, n,
221 $ a, lda, work, su, work( 3*n+1 ), info )
222 ELSE
223*
224* Multiply by inv(U**T).
225*
226 CALL slatrs( 'Upper', 'Transpose', 'Non-unit', normin, n, a,
227 $ lda, work, su, work( 3*n+1 ), info )
228*
229* Multiply by inv(L**T).
230*
231 CALL slatrs( 'Lower', 'Transpose', 'Unit', normin, n, a,
232 $ lda, work, sl, work( 2*n+1 ), info )
233 END IF
234*
235* Divide X by 1/(SL*SU) if doing so will not cause overflow.
236*
237 scale = sl*su
238 normin = 'Y'
239 IF( scale.NE.one ) THEN
240 ix = isamax( n, work, 1 )
241 IF( scale.LT.abs( work( ix ) )*smlnum .OR. scale.EQ.zero )
242 $ GO TO 20
243 CALL srscl( n, scale, work, 1 )
244 END IF
245 GO TO 10
246 END IF
247*
248* Compute the estimate of the reciprocal condition number.
249*
250 IF( ainvnm.NE.zero )
251 $ rcond = ( one / ainvnm ) / anorm
252*
253 20 CONTINUE
254 RETURN
255*
256* End of SGECON
257*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
slatrs
subroutine slatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
SLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition slatrs.f:238
srscl
subroutine srscl(n, sa, sx, incx)
SRSCL multiplies a vector by the reciprocal of a real scalar.
Definition srscl.f:84
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

◆ sgeequ()

subroutine sgeequ ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) r,
real, dimension( * ) c,
real rowcnd,
real colcnd,
real amax,
integer info )

SGEEQU

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

Purpose:
!>
!> SGEEQU computes row and column scalings intended to equilibrate an
!> M-by-N matrix A and reduce its condition number.  R returns the row
!> scale factors and C the column scale factors, chosen to try to make
!> the largest element in each row and column of the matrix B with
!> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!>
!> R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!> number and BIGNUM = largest safe number.  Use of these scaling
!> factors is not guaranteed to reduce the condition number of A but
!> works well in practice.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is REAL array, dimension (LDA,N)
!>          The M-by-N matrix whose equilibration factors are
!>          to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]R
!>          R is REAL array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is REAL array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is REAL
!>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!>          AMAX is neither too large nor too small, it is not worth
!>          scaling by R.
!>
[out]COLCND
!>          COLCND is REAL
!>          If INFO = 0, COLCND contains the ratio of the smallest
!>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!>          worth scaling by C.
!>
[out]AMAX
!>          AMAX is REAL
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i,  and i is
!>                <= M:  the i-th row of A is exactly zero
!>                >  M:  the (i-M)-th column of A is exactly zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file sgeequ.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 INTEGER INFO, LDA, M, N
146 REAL AMAX, COLCND, ROWCND
147* ..
148* .. Array Arguments ..
149 REAL A( LDA, * ), C( * ), R( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 REAL ONE, ZERO
156 parameter( one = 1.0e+0, zero = 0.0e+0 )
157* ..
158* .. Local Scalars ..
159 INTEGER I, J
160 REAL BIGNUM, RCMAX, RCMIN, SMLNUM
161* ..
162* .. External Functions ..
163 REAL SLAMCH
164 EXTERNAL slamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, min
171* ..
172* .. Executable Statements ..
173*
174* Test the input parameters.
175*
176 info = 0
177 IF( m.LT.0 ) THEN
178 info = -1
179 ELSE IF( n.LT.0 ) THEN
180 info = -2
181 ELSE IF( lda.LT.max( 1, m ) ) THEN
182 info = -4
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'SGEEQU', -info )
186 RETURN
187 END IF
188*
189* Quick return if possible
190*
191 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
192 rowcnd = one
193 colcnd = one
194 amax = zero
195 RETURN
196 END IF
197*
198* Get machine constants.
199*
200 smlnum = slamch( 'S' )
201 bignum = one / smlnum
202*
203* Compute row scale factors.
204*
205 DO 10 i = 1, m
206 r( i ) = zero
207 10 CONTINUE
208*
209* Find the maximum element in each row.
210*
211 DO 30 j = 1, n
212 DO 20 i = 1, m
213 r( i ) = max( r( i ), abs( a( i, j ) ) )
214 20 CONTINUE
215 30 CONTINUE
216*
217* Find the maximum and minimum scale factors.
218*
219 rcmin = bignum
220 rcmax = zero
221 DO 40 i = 1, m
222 rcmax = max( rcmax, r( i ) )
223 rcmin = min( rcmin, r( i ) )
224 40 CONTINUE
225 amax = rcmax
226*
227 IF( rcmin.EQ.zero ) THEN
228*
229* Find the first zero scale factor and return an error code.
230*
231 DO 50 i = 1, m
232 IF( r( i ).EQ.zero ) THEN
233 info = i
234 RETURN
235 END IF
236 50 CONTINUE
237 ELSE
238*
239* Invert the scale factors.
240*
241 DO 60 i = 1, m
242 r( i ) = one / min( max( r( i ), smlnum ), bignum )
243 60 CONTINUE
244*
245* Compute ROWCND = min(R(I)) / max(R(I))
246*
247 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
248 END IF
249*
250* Compute column scale factors
251*
252 DO 70 j = 1, n
253 c( j ) = zero
254 70 CONTINUE
255*
256* Find the maximum element in each column,
257* assuming the row scaling computed above.
258*
259 DO 90 j = 1, n
260 DO 80 i = 1, m
261 c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
262 80 CONTINUE
263 90 CONTINUE
264*
265* Find the maximum and minimum scale factors.
266*
267 rcmin = bignum
268 rcmax = zero
269 DO 100 j = 1, n
270 rcmin = min( rcmin, c( j ) )
271 rcmax = max( rcmax, c( j ) )
272 100 CONTINUE
273*
274 IF( rcmin.EQ.zero ) THEN
275*
276* Find the first zero scale factor and return an error code.
277*
278 DO 110 j = 1, n
279 IF( c( j ).EQ.zero ) THEN
280 info = m + j
281 RETURN
282 END IF
283 110 CONTINUE
284 ELSE
285*
286* Invert the scale factors.
287*
288 DO 120 j = 1, n
289 c( j ) = one / min( max( c( j ), smlnum ), bignum )
290 120 CONTINUE
291*
292* Compute COLCND = min(C(J)) / max(C(J))
293*
294 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
295 END IF
296*
297 RETURN
298*
299* End of SGEEQU
300*

◆ sgeequb()

subroutine sgeequb ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) r,
real, dimension( * ) c,
real rowcnd,
real colcnd,
real amax,
integer info )

SGEEQUB

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

Purpose:
!>
!> SGEEQUB computes row and column scalings intended to equilibrate an
!> M-by-N matrix A and reduce its condition number.  R returns the row
!> scale factors and C the column scale factors, chosen to try to make
!> the largest element in each row and column of the matrix B with
!> elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!> the radix.
!>
!> R(i) and C(j) are restricted to be a power of the radix between
!> SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use
!> of these scaling factors is not guaranteed to reduce the condition
!> number of A but works well in practice.
!>
!> This routine differs from SGEEQU by restricting the scaling factors
!> to a power of the radix.  Barring over- and underflow, scaling by
!> these factors introduces no additional rounding errors.  However, the
!> scaled entries' magnitudes are no longer approximately 1 but lie
!> between sqrt(radix) and 1/sqrt(radix).
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is REAL array, dimension (LDA,N)
!>          The M-by-N matrix whose equilibration factors are
!>          to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]R
!>          R is REAL array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is REAL array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is REAL
!>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!>          AMAX is neither too large nor too small, it is not worth
!>          scaling by R.
!>
[out]COLCND
!>          COLCND is REAL
!>          If INFO = 0, COLCND contains the ratio of the smallest
!>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!>          worth scaling by C.
!>
[out]AMAX
!>          AMAX is REAL
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i,  and i is
!>                <= M:  the i-th row of A is exactly zero
!>                >  M:  the (i-M)-th column of A is exactly zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file sgeequb.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 INTEGER INFO, LDA, M, N
153 REAL AMAX, COLCND, ROWCND
154* ..
155* .. Array Arguments ..
156 REAL A( LDA, * ), C( * ), R( * )
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 INTEGER I, J
167 REAL BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX
168* ..
169* .. External Functions ..
170 REAL SLAMCH
171 EXTERNAL slamch
172* ..
173* .. External Subroutines ..
174 EXTERNAL xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, max, min, log
178* ..
179* .. Executable Statements ..
180*
181* Test the input parameters.
182*
183 info = 0
184 IF( m.LT.0 ) THEN
185 info = -1
186 ELSE IF( n.LT.0 ) THEN
187 info = -2
188 ELSE IF( lda.LT.max( 1, m ) ) THEN
189 info = -4
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'SGEEQUB', -info )
193 RETURN
194 END IF
195*
196* Quick return if possible.
197*
198 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
199 rowcnd = one
200 colcnd = one
201 amax = zero
202 RETURN
203 END IF
204*
205* Get machine constants. Assume SMLNUM is a power of the radix.
206*
207 smlnum = slamch( 'S' )
208 bignum = one / smlnum
209 radix = slamch( 'B' )
210 logrdx = log( radix )
211*
212* Compute row scale factors.
213*
214 DO 10 i = 1, m
215 r( i ) = zero
216 10 CONTINUE
217*
218* Find the maximum element in each row.
219*
220 DO 30 j = 1, n
221 DO 20 i = 1, m
222 r( i ) = max( r( i ), abs( a( i, j ) ) )
223 20 CONTINUE
224 30 CONTINUE
225 DO i = 1, m
226 IF( r( i ).GT.zero ) THEN
227 r( i ) = radix**int( log( r( i ) ) / logrdx )
228 END IF
229 END DO
230*
231* Find the maximum and minimum scale factors.
232*
233 rcmin = bignum
234 rcmax = zero
235 DO 40 i = 1, m
236 rcmax = max( rcmax, r( i ) )
237 rcmin = min( rcmin, r( i ) )
238 40 CONTINUE
239 amax = rcmax
240*
241 IF( rcmin.EQ.zero ) THEN
242*
243* Find the first zero scale factor and return an error code.
244*
245 DO 50 i = 1, m
246 IF( r( i ).EQ.zero ) THEN
247 info = i
248 RETURN
249 END IF
250 50 CONTINUE
251 ELSE
252*
253* Invert the scale factors.
254*
255 DO 60 i = 1, m
256 r( i ) = one / min( max( r( i ), smlnum ), bignum )
257 60 CONTINUE
258*
259* Compute ROWCND = min(R(I)) / max(R(I)).
260*
261 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
262 END IF
263*
264* Compute column scale factors
265*
266 DO 70 j = 1, n
267 c( j ) = zero
268 70 CONTINUE
269*
270* Find the maximum element in each column,
271* assuming the row scaling computed above.
272*
273 DO 90 j = 1, n
274 DO 80 i = 1, m
275 c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
276 80 CONTINUE
277 IF( c( j ).GT.zero ) THEN
278 c( j ) = radix**int( log( c( j ) ) / logrdx )
279 END IF
280 90 CONTINUE
281*
282* Find the maximum and minimum scale factors.
283*
284 rcmin = bignum
285 rcmax = zero
286 DO 100 j = 1, n
287 rcmin = min( rcmin, c( j ) )
288 rcmax = max( rcmax, c( j ) )
289 100 CONTINUE
290*
291 IF( rcmin.EQ.zero ) THEN
292*
293* Find the first zero scale factor and return an error code.
294*
295 DO 110 j = 1, n
296 IF( c( j ).EQ.zero ) THEN
297 info = m + j
298 RETURN
299 END IF
300 110 CONTINUE
301 ELSE
302*
303* Invert the scale factors.
304*
305 DO 120 j = 1, n
306 c( j ) = one / min( max( c( j ), smlnum ), bignum )
307 120 CONTINUE
308*
309* Compute COLCND = min(C(J)) / max(C(J)).
310*
311 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
312 END IF
313*
314 RETURN
315*
316* End of SGEEQUB
317*

◆ sgehd2()

subroutine sgehd2 ( integer n,
integer ilo,
integer ihi,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.

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

Purpose:
!>
!> SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
!> an orthogonal similarity transformation:  Q**T * A * Q = H .
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          It is assumed that A is already upper triangular in rows
!>          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
!>          set by a previous call to SGEBAL; otherwise they should be
!>          set to 1 and N respectively. See Further Details.
!>          1 <= ILO <= IHI <= max(1,N).
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the n by n general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, 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]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 (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.
Further Details:
!>
!>  The matrix Q is represented as a product of (ihi-ilo) elementary
!>  reflectors
!>
!>     Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
!>  exit in A(i+2:ihi,i), and tau in TAU(i).
!>
!>  The contents of A are illustrated by the following example, with
!>  n = 7, ilo = 2 and ihi = 6:
!>
!>  on entry,                        on exit,
!>
!>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
!>  (                         a )    (                          a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>

Definition at line 148 of file sgehd2.f.

149*
150* -- LAPACK computational routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER IHI, ILO, INFO, LDA, N
156* ..
157* .. Array Arguments ..
158 REAL A( LDA, * ), TAU( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 REAL ONE
165 parameter( one = 1.0e+0 )
166* ..
167* .. Local Scalars ..
168 INTEGER I
169 REAL AII
170* ..
171* .. External Subroutines ..
172 EXTERNAL slarf, slarfg, xerbla
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC max, min
176* ..
177* .. Executable Statements ..
178*
179* Test the input parameters
180*
181 info = 0
182 IF( n.LT.0 ) THEN
183 info = -1
184 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
185 info = -2
186 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
187 info = -3
188 ELSE IF( lda.LT.max( 1, n ) ) THEN
189 info = -5
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'SGEHD2', -info )
193 RETURN
194 END IF
195*
196 DO 10 i = ilo, ihi - 1
197*
198* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
199*
200 CALL slarfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1,
201 $ tau( i ) )
202 aii = a( i+1, i )
203 a( i+1, i ) = one
204*
205* Apply H(i) to A(1:ihi,i+1:ihi) from the right
206*
207 CALL slarf( 'Right', ihi, ihi-i, a( i+1, i ), 1, tau( i ),
208 $ a( 1, i+1 ), lda, work )
209*
210* Apply H(i) to A(i+1:ihi,i+1:n) from the left
211*
212 CALL slarf( 'Left', ihi-i, n-i, a( i+1, i ), 1, tau( i ),
213 $ a( i+1, i+1 ), lda, work )
214*
215 a( i+1, i ) = aii
216 10 CONTINUE
217*
218 RETURN
219*
220* End of SGEHD2
221*

◆ sgehrd()

subroutine sgehrd ( integer n,
integer ilo,
integer ihi,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGEHRD

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

Purpose:
!>
!> SGEHRD reduces a real general matrix A to upper Hessenberg form H by
!> an orthogonal similarity transformation:  Q**T * A * Q = H .
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          It is assumed that A is already upper triangular in rows
!>          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
!>          set by a previous call to SGEBAL; otherwise they should be
!>          set to 1 and N respectively. See Further Details.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the N-by-N general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, 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]TAU
!>          TAU is REAL array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
!>          zero.
!>
[out]WORK
!>          WORK is REAL array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= max(1,N).
!>          For good performance, LWORK should generally be larger.
!>
!>          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:
!>
!>  The matrix Q is represented as a product of (ihi-ilo) elementary
!>  reflectors
!>
!>     Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
!>  exit in A(i+2:ihi,i), and tau in TAU(i).
!>
!>  The contents of A are illustrated by the following example, with
!>  n = 7, ilo = 2 and ihi = 6:
!>
!>  on entry,                        on exit,
!>
!>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
!>  (                         a )    (                          a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>
!>  This file is a slight modification of LAPACK-3.0's SGEHRD
!>  subroutine incorporating improvements proposed by Quintana-Orti and
!>  Van de Geijn (2006). (See SLAHR2.)
!>

Definition at line 166 of file sgehrd.f.

167*
168* -- LAPACK computational routine --
169* -- LAPACK is a software package provided by Univ. of Tennessee, --
170* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171*
172* .. Scalar Arguments ..
173 INTEGER IHI, ILO, INFO, LDA, LWORK, N
174* ..
175* .. Array Arguments ..
176 REAL A( LDA, * ), TAU( * ), WORK( * )
177* ..
178*
179* =====================================================================
180*
181* .. Parameters ..
182 INTEGER NBMAX, LDT, TSIZE
183 parameter( nbmax = 64, ldt = nbmax+1,
184 $ tsize = ldt*nbmax )
185 REAL ZERO, ONE
186 parameter( zero = 0.0e+0,
187 $ one = 1.0e+0 )
188* ..
189* .. Local Scalars ..
190 LOGICAL LQUERY
191 INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
192 $ NBMIN, NH, NX
193 REAL EI
194* ..
195* .. External Subroutines ..
196 EXTERNAL saxpy, sgehd2, sgemm, slahr2, slarfb, strmm,
197 $ xerbla
198* ..
199* .. Intrinsic Functions ..
200 INTRINSIC max, min
201* ..
202* .. External Functions ..
203 INTEGER ILAENV
204 EXTERNAL ilaenv
205* ..
206* .. Executable Statements ..
207*
208* Test the input parameters
209*
210 info = 0
211 lquery = ( lwork.EQ.-1 )
212 IF( n.LT.0 ) THEN
213 info = -1
214 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
215 info = -2
216 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
217 info = -3
218 ELSE IF( lda.LT.max( 1, n ) ) THEN
219 info = -5
220 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
221 info = -8
222 END IF
223*
224 IF( info.EQ.0 ) THEN
225*
226* Compute the workspace requirements
227*
228 nb = min( nbmax, ilaenv( 1, 'SGEHRD', ' ', n, ilo, ihi, -1 ) )
229 lwkopt = n*nb + tsize
230 work( 1 ) = lwkopt
231 END IF
232*
233 IF( info.NE.0 ) THEN
234 CALL xerbla( 'SGEHRD', -info )
235 RETURN
236 ELSE IF( lquery ) THEN
237 RETURN
238 END IF
239*
240* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
241*
242 DO 10 i = 1, ilo - 1
243 tau( i ) = zero
244 10 CONTINUE
245 DO 20 i = max( 1, ihi ), n - 1
246 tau( i ) = zero
247 20 CONTINUE
248*
249* Quick return if possible
250*
251 nh = ihi - ilo + 1
252 IF( nh.LE.1 ) THEN
253 work( 1 ) = 1
254 RETURN
255 END IF
256*
257* Determine the block size
258*
259 nb = min( nbmax, ilaenv( 1, 'SGEHRD', ' ', n, ilo, ihi, -1 ) )
260 nbmin = 2
261 IF( nb.GT.1 .AND. nb.LT.nh ) THEN
262*
263* Determine when to cross over from blocked to unblocked code
264* (last block is always handled by unblocked code)
265*
266 nx = max( nb, ilaenv( 3, 'SGEHRD', ' ', n, ilo, ihi, -1 ) )
267 IF( nx.LT.nh ) THEN
268*
269* Determine if workspace is large enough for blocked code
270*
271 IF( lwork.LT.n*nb+tsize ) THEN
272*
273* Not enough workspace to use optimal NB: determine the
274* minimum value of NB, and reduce NB or force use of
275* unblocked code
276*
277 nbmin = max( 2, ilaenv( 2, 'SGEHRD', ' ', n, ilo, ihi,
278 $ -1 ) )
279 IF( lwork.GE.(n*nbmin + tsize) ) THEN
280 nb = (lwork-tsize) / n
281 ELSE
282 nb = 1
283 END IF
284 END IF
285 END IF
286 END IF
287 ldwork = n
288*
289 IF( nb.LT.nbmin .OR. nb.GE.nh ) THEN
290*
291* Use unblocked code below
292*
293 i = ilo
294*
295 ELSE
296*
297* Use blocked code
298*
299 iwt = 1 + n*nb
300 DO 40 i = ilo, ihi - 1 - nx, nb
301 ib = min( nb, ihi-i )
302*
303* Reduce columns i:i+ib-1 to Hessenberg form, returning the
304* matrices V and T of the block reflector H = I - V*T*V**T
305* which performs the reduction, and also the matrix Y = A*V*T
306*
307 CALL slahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),
308 $ work( iwt ), ldt, work, ldwork )
309*
310* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
311* right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set
312* to 1
313*
314 ei = a( i+ib, i+ib-1 )
315 a( i+ib, i+ib-1 ) = one
316 CALL sgemm( 'No transpose', 'Transpose',
317 $ ihi, ihi-i-ib+1,
318 $ ib, -one, work, ldwork, a( i+ib, i ), lda, one,
319 $ a( 1, i+ib ), lda )
320 a( i+ib, i+ib-1 ) = ei
321*
322* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
323* right
324*
325 CALL strmm( 'Right', 'Lower', 'Transpose',
326 $ 'Unit', i, ib-1,
327 $ one, a( i+1, i ), lda, work, ldwork )
328 DO 30 j = 0, ib-2
329 CALL saxpy( i, -one, work( ldwork*j+1 ), 1,
330 $ a( 1, i+j+1 ), 1 )
331 30 CONTINUE
332*
333* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
334* left
335*
336 CALL slarfb( 'Left', 'Transpose', 'Forward',
337 $ 'Columnwise',
338 $ ihi-i, n-i-ib+1, ib, a( i+1, i ), lda,
339 $ work( iwt ), ldt, a( i+1, i+ib ), lda,
340 $ work, ldwork )
341 40 CONTINUE
342 END IF
343*
344* Use unblocked code to reduce the rest of the matrix
345*
346 CALL sgehd2( n, i, ihi, a, lda, tau, work, iinfo )
347 work( 1 ) = lwkopt
348*
349 RETURN
350*
351* End of SGEHRD
352*
sgehd2
subroutine sgehd2(n, ilo, ihi, a, lda, tau, work, info)
SGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
Definition sgehd2.f:149
slahr2
subroutine slahr2(n, k, nb, a, lda, tau, t, ldt, y, ldy)
SLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elemen...
Definition slahr2.f:181
slarfb
subroutine slarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
SLARFB applies a block reflector or its transpose to a general rectangular matrix.
Definition slarfb.f:197
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ sgelq2()

subroutine sgelq2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> SGELQ2 computes an LQ factorization of a real m-by-n matrix A:
!>
!>    A = ( L 0 ) *  Q
!>
!> where:
!>
!>    Q is a n-by-n orthogonal matrix;
!>    L is a lower-triangular m-by-m matrix;
!>    0 is a m-by-(n-m) zero matrix, if m < n.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m by min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is REAL array, dimension (M)
!>
[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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!>  and tau in TAU(i).
!>

Definition at line 128 of file sgelq2.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 INTEGER INFO, LDA, M, N
136* ..
137* .. Array Arguments ..
138 REAL A( LDA, * ), TAU( * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 REAL ONE
145 parameter( one = 1.0e+0 )
146* ..
147* .. Local Scalars ..
148 INTEGER I, K
149 REAL AII
150* ..
151* .. External Subroutines ..
152 EXTERNAL slarf, slarfg, xerbla
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. Executable Statements ..
158*
159* Test the input arguments
160*
161 info = 0
162 IF( m.LT.0 ) THEN
163 info = -1
164 ELSE IF( n.LT.0 ) THEN
165 info = -2
166 ELSE IF( lda.LT.max( 1, m ) ) THEN
167 info = -4
168 END IF
169 IF( info.NE.0 ) THEN
170 CALL xerbla( 'SGELQ2', -info )
171 RETURN
172 END IF
173*
174 k = min( m, n )
175*
176 DO 10 i = 1, k
177*
178* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
179*
180 CALL slarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,
181 $ tau( i ) )
182 IF( i.LT.m ) THEN
183*
184* Apply H(i) to A(i+1:m,i:n) from the right
185*
186 aii = a( i, i )
187 a( i, i ) = one
188 CALL slarf( 'Right', m-i, n-i+1, a( i, i ), lda, tau( i ),
189 $ a( i+1, i ), lda, work )
190 a( i, i ) = aii
191 END IF
192 10 CONTINUE
193 RETURN
194*
195* End of SGELQ2
196*

◆ sgelqf()

subroutine sgelqf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGELQF

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

Purpose:
!>
!> SGELQF computes an LQ factorization of a real M-by-N matrix A:
!>
!>    A = ( L 0 ) *  Q
!>
!> where:
!>
!>    Q is a N-by-N orthogonal matrix;
!>    L is a lower-triangular M-by-M matrix;
!>    0 is a M-by-(N-M) zero matrix, if M < N.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          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 >= max(1,M).
!>          For optimum performance LWORK >= M*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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!>  and tau in TAU(i).
!>

Definition at line 142 of file sgelqf.f.

143*
144* -- LAPACK computational routine --
145* -- LAPACK is a software package provided by Univ. of Tennessee, --
146* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
147*
148* .. Scalar Arguments ..
149 INTEGER INFO, LDA, LWORK, M, N
150* ..
151* .. Array Arguments ..
152 REAL A( LDA, * ), TAU( * ), WORK( * )
153* ..
154*
155* =====================================================================
156*
157* .. Local Scalars ..
158 LOGICAL LQUERY
159 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
160 $ NBMIN, NX
161* ..
162* .. External Subroutines ..
163 EXTERNAL sgelq2, slarfb, slarft, xerbla
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC max, min
167* ..
168* .. External Functions ..
169 INTEGER ILAENV
170 EXTERNAL ilaenv
171* ..
172* .. Executable Statements ..
173*
174* Test the input arguments
175*
176 info = 0
177 nb = ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 )
178 lwkopt = m*nb
179 work( 1 ) = lwkopt
180 lquery = ( lwork.EQ.-1 )
181 IF( m.LT.0 ) THEN
182 info = -1
183 ELSE IF( n.LT.0 ) THEN
184 info = -2
185 ELSE IF( lda.LT.max( 1, m ) ) THEN
186 info = -4
187 ELSE IF( lwork.LT.max( 1, m ) .AND. .NOT.lquery ) THEN
188 info = -7
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'SGELQF', -info )
192 RETURN
193 ELSE IF( lquery ) THEN
194 RETURN
195 END IF
196*
197* Quick return if possible
198*
199 k = min( m, n )
200 IF( k.EQ.0 ) THEN
201 work( 1 ) = 1
202 RETURN
203 END IF
204*
205 nbmin = 2
206 nx = 0
207 iws = m
208 IF( nb.GT.1 .AND. nb.LT.k ) THEN
209*
210* Determine when to cross over from blocked to unblocked code.
211*
212 nx = max( 0, ilaenv( 3, 'SGELQF', ' ', m, n, -1, -1 ) )
213 IF( nx.LT.k ) THEN
214*
215* Determine if workspace is large enough for blocked code.
216*
217 ldwork = m
218 iws = ldwork*nb
219 IF( lwork.LT.iws ) THEN
220*
221* Not enough workspace to use optimal NB: reduce NB and
222* determine the minimum value of NB.
223*
224 nb = lwork / ldwork
225 nbmin = max( 2, ilaenv( 2, 'SGELQF', ' ', m, n, -1,
226 $ -1 ) )
227 END IF
228 END IF
229 END IF
230*
231 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
232*
233* Use blocked code initially
234*
235 DO 10 i = 1, k - nx, nb
236 ib = min( k-i+1, nb )
237*
238* Compute the LQ factorization of the current block
239* A(i:i+ib-1,i:n)
240*
241 CALL sgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,
242 $ iinfo )
243 IF( i+ib.LE.m ) THEN
244*
245* Form the triangular factor of the block reflector
246* H = H(i) H(i+1) . . . H(i+ib-1)
247*
248 CALL slarft( 'Forward', 'Rowwise', n-i+1, ib, a( i, i ),
249 $ lda, tau( i ), work, ldwork )
250*
251* Apply H to A(i+ib:m,i:n) from the right
252*
253 CALL slarfb( 'Right', 'No transpose', 'Forward',
254 $ 'Rowwise', m-i-ib+1, n-i+1, ib, a( i, i ),
255 $ lda, work, ldwork, a( i+ib, i ), lda,
256 $ work( ib+1 ), ldwork )
257 END IF
258 10 CONTINUE
259 ELSE
260 i = 1
261 END IF
262*
263* Use unblocked code to factor the last or only block.
264*
265 IF( i.LE.k )
266 $ CALL sgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,
267 $ iinfo )
268*
269 work( 1 ) = iws
270 RETURN
271*
272* End of SGELQF
273*
sgelq2
subroutine sgelq2(m, n, a, lda, tau, work, info)
SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgelq2.f:129
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

◆ sgemqrt()

subroutine sgemqrt ( character side,
character trans,
integer m,
integer n,
integer k,
integer nb,
real, dimension( ldv, * ) v,
integer ldv,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) work,
integer info )

SGEMQRT

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

Purpose:
!>
!> SGEMQRT overwrites the general real M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q C            C Q
!> TRANS = 'T':   Q**T C            C Q**T
!>
!> where Q is a real orthogonal matrix defined as the product of K
!> elementary reflectors:
!>
!>       Q = H(1) H(2) . . . H(K) = I - V T V**T
!>
!> generated using the compact WY representation as returned by SGEQRT.
!>
!> Q is of order M if SIDE = 'L' and of order N  if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The block size used for the storage of T.  K >= NB >= 1.
!>          This must be the same value of NB used to generate T
!>          in SGEQRT.
!>
[in]V
!>          V is REAL array, dimension (LDV,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          SGEQRT in the first K columns of its array argument A.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!>
[in]T
!>          T is REAL array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by SGEQRT, stored as a NB-by-N matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[in,out]C
!>          C is REAL array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is REAL array. The dimension of WORK is
!>           N*NB if SIDE = 'L', or  M*NB if SIDE = 'R'.
!>
[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 166 of file sgemqrt.f.

168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 CHARACTER SIDE, TRANS
175 INTEGER INFO, K, LDV, LDC, M, N, NB, LDT
176* ..
177* .. Array Arguments ..
178 REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* ..
184* .. Local Scalars ..
185 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
186 INTEGER I, IB, LDWORK, KF, Q
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL xerbla, slarfb
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC max, min
197* ..
198* .. Executable Statements ..
199*
200* .. Test the input arguments ..
201*
202 info = 0
203 left = lsame( side, 'L' )
204 right = lsame( side, 'R' )
205 tran = lsame( trans, 'T' )
206 notran = lsame( trans, 'N' )
207*
208 IF( left ) THEN
209 ldwork = max( 1, n )
210 q = m
211 ELSE IF ( right ) THEN
212 ldwork = max( 1, m )
213 q = n
214 END IF
215 IF( .NOT.left .AND. .NOT.right ) THEN
216 info = -1
217 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
218 info = -2
219 ELSE IF( m.LT.0 ) THEN
220 info = -3
221 ELSE IF( n.LT.0 ) THEN
222 info = -4
223 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
224 info = -5
225 ELSE IF( nb.LT.1 .OR. (nb.GT.k .AND. k.GT.0)) THEN
226 info = -6
227 ELSE IF( ldv.LT.max( 1, q ) ) THEN
228 info = -8
229 ELSE IF( ldt.LT.nb ) THEN
230 info = -10
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -12
233 END IF
234*
235 IF( info.NE.0 ) THEN
236 CALL xerbla( 'SGEMQRT', -info )
237 RETURN
238 END IF
239*
240* .. Quick return if possible ..
241*
242 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
243*
244 IF( left .AND. tran ) THEN
245*
246 DO i = 1, k, nb
247 ib = min( nb, k-i+1 )
248 CALL slarfb( 'L', 'T', 'F', 'C', m-i+1, n, ib,
249 $ v( i, i ), ldv, t( 1, i ), ldt,
250 $ c( i, 1 ), ldc, work, ldwork )
251 END DO
252*
253 ELSE IF( right .AND. notran ) THEN
254*
255 DO i = 1, k, nb
256 ib = min( nb, k-i+1 )
257 CALL slarfb( 'R', 'N', 'F', 'C', m, n-i+1, ib,
258 $ v( i, i ), ldv, t( 1, i ), ldt,
259 $ c( 1, i ), ldc, work, ldwork )
260 END DO
261*
262 ELSE IF( left .AND. notran ) THEN
263*
264 kf = ((k-1)/nb)*nb+1
265 DO i = kf, 1, -nb
266 ib = min( nb, k-i+1 )
267 CALL slarfb( 'L', 'N', 'F', 'C', m-i+1, n, ib,
268 $ v( i, i ), ldv, t( 1, i ), ldt,
269 $ c( i, 1 ), ldc, work, ldwork )
270 END DO
271*
272 ELSE IF( right .AND. tran ) THEN
273*
274 kf = ((k-1)/nb)*nb+1
275 DO i = kf, 1, -nb
276 ib = min( nb, k-i+1 )
277 CALL slarfb( 'R', 'T', 'F', 'C', m, n-i+1, ib,
278 $ v( i, i ), ldv, t( 1, i ), ldt,
279 $ c( 1, i ), ldc, work, ldwork )
280 END DO
281*
282 END IF
283*
284 RETURN
285*
286* End of SGEMQRT
287*

◆ sgeql2()

subroutine sgeql2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> SGEQL2 computes a QL factorization of a real m by n matrix A:
!> A = Q * L.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, if m >= n, the lower triangle of the subarray
!>          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
!>          if m <= n, the elements on and below the (n-m)-th
!>          superdiagonal contain the m by n lower trapezoidal matrix L;
!>          the remaining elements, 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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
!>  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
!>

Definition at line 122 of file sgeql2.f.

123*
124* -- LAPACK computational routine --
125* -- LAPACK is a software package provided by Univ. of Tennessee, --
126* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
127*
128* .. Scalar Arguments ..
129 INTEGER INFO, LDA, M, N
130* ..
131* .. Array Arguments ..
132 REAL A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 REAL ONE
139 parameter( one = 1.0e+0 )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 REAL AII
144* ..
145* .. External Subroutines ..
146 EXTERNAL slarf, slarfg, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC max, min
150* ..
151* .. Executable Statements ..
152*
153* Test the input arguments
154*
155 info = 0
156 IF( m.LT.0 ) THEN
157 info = -1
158 ELSE IF( n.LT.0 ) THEN
159 info = -2
160 ELSE IF( lda.LT.max( 1, m ) ) THEN
161 info = -4
162 END IF
163 IF( info.NE.0 ) THEN
164 CALL xerbla( 'SGEQL2', -info )
165 RETURN
166 END IF
167*
168 k = min( m, n )
169*
170 DO 10 i = k, 1, -1
171*
172* Generate elementary reflector H(i) to annihilate
173* A(1:m-k+i-1,n-k+i)
174*
175 CALL slarfg( m-k+i, a( m-k+i, n-k+i ), a( 1, n-k+i ), 1,
176 $ tau( i ) )
177*
178* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
179*
180 aii = a( m-k+i, n-k+i )
181 a( m-k+i, n-k+i ) = one
182 CALL slarf( 'Left', m-k+i, n-k+i-1, a( 1, n-k+i ), 1, tau( i ),
183 $ a, lda, work )
184 a( m-k+i, n-k+i ) = aii
185 10 CONTINUE
186 RETURN
187*
188* End of SGEQL2
189*

◆ sgeqlf()

subroutine sgeqlf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGEQLF

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

Purpose:
!>
!> SGEQLF computes a QL factorization of a real M-by-N matrix A:
!> A = Q * L.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          if m >= n, the lower triangle of the subarray
!>          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
!>          if m <= n, the elements on and below the (n-m)-th
!>          superdiagonal contain the M-by-N lower trapezoidal matrix L;
!>          the remaining elements, 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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          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 >= max(1,N).
!>          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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
!>  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
!>

Definition at line 137 of file sgeqlf.f.

138*
139* -- LAPACK computational routine --
140* -- LAPACK is a software package provided by Univ. of Tennessee, --
141* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
142*
143* .. Scalar Arguments ..
144 INTEGER INFO, LDA, LWORK, M, N
145* ..
146* .. Array Arguments ..
147 REAL A( LDA, * ), TAU( * ), WORK( * )
148* ..
149*
150* =====================================================================
151*
152* .. Local Scalars ..
153 LOGICAL LQUERY
154 INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
155 $ MU, NB, NBMIN, NU, NX
156* ..
157* .. External Subroutines ..
158 EXTERNAL sgeql2, slarfb, slarft, xerbla
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC max, min
162* ..
163* .. External Functions ..
164 INTEGER ILAENV
165 EXTERNAL ilaenv
166* ..
167* .. Executable Statements ..
168*
169* Test the input arguments
170*
171 info = 0
172 lquery = ( lwork.EQ.-1 )
173 IF( m.LT.0 ) THEN
174 info = -1
175 ELSE IF( n.LT.0 ) THEN
176 info = -2
177 ELSE IF( lda.LT.max( 1, m ) ) THEN
178 info = -4
179 END IF
180*
181 IF( info.EQ.0 ) THEN
182 k = min( m, n )
183 IF( k.EQ.0 ) THEN
184 lwkopt = 1
185 ELSE
186 nb = ilaenv( 1, 'SGEQLF', ' ', m, n, -1, -1 )
187 lwkopt = n*nb
188 END IF
189 work( 1 ) = lwkopt
190*
191 IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
192 info = -7
193 END IF
194 END IF
195*
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'SGEQLF', -info )
198 RETURN
199 ELSE IF( lquery ) THEN
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 IF( k.EQ.0 ) THEN
206 RETURN
207 END IF
208*
209 nbmin = 2
210 nx = 1
211 iws = n
212 IF( nb.GT.1 .AND. nb.LT.k ) THEN
213*
214* Determine when to cross over from blocked to unblocked code.
215*
216 nx = max( 0, ilaenv( 3, 'SGEQLF', ' ', m, n, -1, -1 ) )
217 IF( nx.LT.k ) THEN
218*
219* Determine if workspace is large enough for blocked code.
220*
221 ldwork = n
222 iws = ldwork*nb
223 IF( lwork.LT.iws ) THEN
224*
225* Not enough workspace to use optimal NB: reduce NB and
226* determine the minimum value of NB.
227*
228 nb = lwork / ldwork
229 nbmin = max( 2, ilaenv( 2, 'SGEQLF', ' ', m, n, -1,
230 $ -1 ) )
231 END IF
232 END IF
233 END IF
234*
235 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
236*
237* Use blocked code initially.
238* The last kk columns are handled by the block method.
239*
240 ki = ( ( k-nx-1 ) / nb )*nb
241 kk = min( k, ki+nb )
242*
243 DO 10 i = k - kk + ki + 1, k - kk + 1, -nb
244 ib = min( k-i+1, nb )
245*
246* Compute the QL factorization of the current block
247* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
248*
249 CALL sgeql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ),
250 $ work, iinfo )
251 IF( n-k+i.GT.1 ) THEN
252*
253* Form the triangular factor of the block reflector
254* H = H(i+ib-1) . . . H(i+1) H(i)
255*
256 CALL slarft( 'Backward', 'Columnwise', m-k+i+ib-1, ib,
257 $ a( 1, n-k+i ), lda, tau( i ), work, ldwork )
258*
259* Apply H**T to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
260*
261 CALL slarfb( 'Left', 'Transpose', 'Backward',
262 $ 'Columnwise', m-k+i+ib-1, n-k+i-1, ib,
263 $ a( 1, n-k+i ), lda, work, ldwork, a, lda,
264 $ work( ib+1 ), ldwork )
265 END IF
266 10 CONTINUE
267 mu = m - k + i + nb - 1
268 nu = n - k + i + nb - 1
269 ELSE
270 mu = m
271 nu = n
272 END IF
273*
274* Use unblocked code to factor the last or only block
275*
276 IF( mu.GT.0 .AND. nu.GT.0 )
277 $ CALL sgeql2( mu, nu, a, lda, tau, work, iinfo )
278*
279 work( 1 ) = iws
280 RETURN
281*
282* End of SGEQLF
283*
sgeql2
subroutine sgeql2(m, n, a, lda, tau, work, info)
SGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgeql2.f:123

◆ sgeqp3()

subroutine sgeqp3 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGEQP3

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

Purpose:
!>
!> SGEQP3 computes a QR factorization with column pivoting of a
!> matrix A:  A*P = Q*R  using Level 3 BLAS.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the upper triangle of the array contains the
!>          min(M,N)-by-N upper trapezoidal matrix R; the elements below
!>          the diagonal, together with the array TAU, represent the
!>          orthogonal matrix Q as a product of min(M,N) elementary
!>          reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
!>          to the front of A*P (a leading column); if JPVT(J)=0,
!>          the J-th column of A is a free column.
!>          On exit, if JPVT(J)=K, then the J-th column of A*P was the
!>          the K-th column of A.
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[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 >= 3*N+1.
!>          For optimal performance LWORK >= 2*N+( 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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real/complex vector
!>  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
!>  A(i+1:m,i), and tau in TAU(i).
!>
Contributors:
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain X. Sun, Computer Science Dept., Duke University, USA

Definition at line 150 of file sgeqp3.f.

151*
152* -- LAPACK computational routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 INTEGER INFO, LDA, LWORK, M, N
158* ..
159* .. Array Arguments ..
160 INTEGER JPVT( * )
161 REAL A( LDA, * ), TAU( * ), WORK( * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 INTEGER INB, INBMIN, IXOVER
168 parameter( inb = 1, inbmin = 2, ixover = 3 )
169* ..
170* .. Local Scalars ..
171 LOGICAL LQUERY
172 INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
173 $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
174* ..
175* .. External Subroutines ..
176 EXTERNAL sgeqrf, slaqp2, slaqps, sormqr, sswap, xerbla
177* ..
178* .. External Functions ..
179 INTEGER ILAENV
180 REAL SNRM2
181 EXTERNAL ilaenv, snrm2
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC int, max, min
185* Test input arguments
186* ====================
187*
188 info = 0
189 lquery = ( lwork.EQ.-1 )
190 IF( m.LT.0 ) THEN
191 info = -1
192 ELSE IF( n.LT.0 ) THEN
193 info = -2
194 ELSE IF( lda.LT.max( 1, m ) ) THEN
195 info = -4
196 END IF
197*
198 IF( info.EQ.0 ) THEN
199 minmn = min( m, n )
200 IF( minmn.EQ.0 ) THEN
201 iws = 1
202 lwkopt = 1
203 ELSE
204 iws = 3*n + 1
205 nb = ilaenv( inb, 'SGEQRF', ' ', m, n, -1, -1 )
206 lwkopt = 2*n + ( n + 1 )*nb
207 END IF
208 work( 1 ) = lwkopt
209*
210 IF( ( lwork.LT.iws ) .AND. .NOT.lquery ) THEN
211 info = -8
212 END IF
213 END IF
214*
215 IF( info.NE.0 ) THEN
216 CALL xerbla( 'SGEQP3', -info )
217 RETURN
218 ELSE IF( lquery ) THEN
219 RETURN
220 END IF
221*
222* Move initial columns up front.
223*
224 nfxd = 1
225 DO 10 j = 1, n
226 IF( jpvt( j ).NE.0 ) THEN
227 IF( j.NE.nfxd ) THEN
228 CALL sswap( m, a( 1, j ), 1, a( 1, nfxd ), 1 )
229 jpvt( j ) = jpvt( nfxd )
230 jpvt( nfxd ) = j
231 ELSE
232 jpvt( j ) = j
233 END IF
234 nfxd = nfxd + 1
235 ELSE
236 jpvt( j ) = j
237 END IF
238 10 CONTINUE
239 nfxd = nfxd - 1
240*
241* Factorize fixed columns
242* =======================
243*
244* Compute the QR factorization of fixed columns and update
245* remaining columns.
246*
247 IF( nfxd.GT.0 ) THEN
248 na = min( m, nfxd )
249*CC CALL SGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
250 CALL sgeqrf( m, na, a, lda, tau, work, lwork, info )
251 iws = max( iws, int( work( 1 ) ) )
252 IF( na.LT.n ) THEN
253*CC CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
254*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO )
255 CALL sormqr( 'Left', 'Transpose', m, n-na, na, a, lda, tau,
256 $ a( 1, na+1 ), lda, work, lwork, info )
257 iws = max( iws, int( work( 1 ) ) )
258 END IF
259 END IF
260*
261* Factorize free columns
262* ======================
263*
264 IF( nfxd.LT.minmn ) THEN
265*
266 sm = m - nfxd
267 sn = n - nfxd
268 sminmn = minmn - nfxd
269*
270* Determine the block size.
271*
272 nb = ilaenv( inb, 'SGEQRF', ' ', sm, sn, -1, -1 )
273 nbmin = 2
274 nx = 0
275*
276 IF( ( nb.GT.1 ) .AND. ( nb.LT.sminmn ) ) THEN
277*
278* Determine when to cross over from blocked to unblocked code.
279*
280 nx = max( 0, ilaenv( ixover, 'SGEQRF', ' ', sm, sn, -1,
281 $ -1 ) )
282*
283*
284 IF( nx.LT.sminmn ) THEN
285*
286* Determine if workspace is large enough for blocked code.
287*
288 minws = 2*sn + ( sn+1 )*nb
289 iws = max( iws, minws )
290 IF( lwork.LT.minws ) THEN
291*
292* Not enough workspace to use optimal NB: Reduce NB and
293* determine the minimum value of NB.
294*
295 nb = ( lwork-2*sn ) / ( sn+1 )
296 nbmin = max( 2, ilaenv( inbmin, 'SGEQRF', ' ', sm, sn,
297 $ -1, -1 ) )
298*
299*
300 END IF
301 END IF
302 END IF
303*
304* Initialize partial column norms. The first N elements of work
305* store the exact column norms.
306*
307 DO 20 j = nfxd + 1, n
308 work( j ) = snrm2( sm, a( nfxd+1, j ), 1 )
309 work( n+j ) = work( j )
310 20 CONTINUE
311*
312 IF( ( nb.GE.nbmin ) .AND. ( nb.LT.sminmn ) .AND.
313 $ ( nx.LT.sminmn ) ) THEN
314*
315* Use blocked code initially.
316*
317 j = nfxd + 1
318*
319* Compute factorization: while loop.
320*
321*
322 topbmn = minmn - nx
323 30 CONTINUE
324 IF( j.LE.topbmn ) THEN
325 jb = min( nb, topbmn-j+1 )
326*
327* Factorize JB columns among columns J:N.
328*
329 CALL slaqps( m, n-j+1, j-1, jb, fjb, a( 1, j ), lda,
330 $ jpvt( j ), tau( j ), work( j ), work( n+j ),
331 $ work( 2*n+1 ), work( 2*n+jb+1 ), n-j+1 )
332*
333 j = j + fjb
334 GO TO 30
335 END IF
336 ELSE
337 j = nfxd + 1
338 END IF
339*
340* Use unblocked code to factor the last or only block.
341*
342*
343 IF( j.LE.minmn )
344 $ CALL slaqp2( m, n-j+1, j-1, a( 1, j ), lda, jpvt( j ),
345 $ tau( j ), work( j ), work( n+j ),
346 $ work( 2*n+1 ) )
347*
348 END IF
349*
350 work( 1 ) = iws
351 RETURN
352*
353* End of SGEQP3
354*
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
slaqps
subroutine slaqps(m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, vn2, auxv, f, ldf)
SLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BL...
Definition slaqps.f:178
slaqp2
subroutine slaqp2(m, n, offset, a, lda, jpvt, tau, vn1, vn2, work)
SLAQP2 computes a QR factorization with column pivoting of the matrix block.
Definition slaqp2.f:149
sormqr
subroutine sormqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMQR
Definition sormqr.f:168

◆ sgeqpf()

subroutine sgeqpf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGEQPF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine SGEQP3.
!>
!> SGEQPF computes a QR factorization with column pivoting of a
!> real M-by-N matrix A: A*P = Q*R.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the upper triangle of the array contains the
!>          min(M,N)-by-N upper triangular matrix R; the elements
!>          below the diagonal, together with the array TAU,
!>          represent the orthogonal matrix Q as a product of
!>          min(m,n) elementary reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!>          to the front of A*P (a leading column); if JPVT(i) = 0,
!>          the i-th column of A is a free column.
!>          On exit, if JPVT(i) = k, then the i-th column of A*P
!>          was the k-th column of A.
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is REAL array, dimension (3*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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(n)
!>
!>  Each H(i) has the form
!>
!>     H = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
!>
!>  The matrix P is represented in jpvt as follows: If
!>     jpvt(j) = i
!>  then the jth column of P is the ith canonical unit vector.
!>
!>  Partial column norm updating strategy modified by
!>    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
!>    University of Zagreb, Croatia.
!>  -- April 2011                                                      --
!>  For more details see LAPACK Working Note 176.
!>

Definition at line 141 of file sgeqpf.f.

142*
143* -- LAPACK computational routine --
144* -- LAPACK is a software package provided by Univ. of Tennessee, --
145* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
146*
147* .. Scalar Arguments ..
148 INTEGER INFO, LDA, M, N
149* ..
150* .. Array Arguments ..
151 INTEGER JPVT( * )
152 REAL A( LDA, * ), TAU( * ), WORK( * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 REAL ZERO, ONE
159 parameter( zero = 0.0e+0, one = 1.0e+0 )
160* ..
161* .. Local Scalars ..
162 INTEGER I, ITEMP, J, MA, MN, PVT
163 REAL AII, TEMP, TEMP2, TOL3Z
164* ..
165* .. External Subroutines ..
166 EXTERNAL sgeqr2, slarf, slarfg, sorm2r, sswap, xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC abs, max, min, sqrt
170* ..
171* .. External Functions ..
172 INTEGER ISAMAX
173 REAL SLAMCH, SNRM2
174 EXTERNAL isamax, slamch, snrm2
175* ..
176* .. Executable Statements ..
177*
178* Test the input arguments
179*
180 info = 0
181 IF( m.LT.0 ) THEN
182 info = -1
183 ELSE IF( n.LT.0 ) THEN
184 info = -2
185 ELSE IF( lda.LT.max( 1, m ) ) THEN
186 info = -4
187 END IF
188 IF( info.NE.0 ) THEN
189 CALL xerbla( 'SGEQPF', -info )
190 RETURN
191 END IF
192*
193 mn = min( m, n )
194 tol3z = sqrt(slamch('Epsilon'))
195*
196* Move initial columns up front
197*
198 itemp = 1
199 DO 10 i = 1, n
200 IF( jpvt( i ).NE.0 ) THEN
201 IF( i.NE.itemp ) THEN
202 CALL sswap( m, a( 1, i ), 1, a( 1, itemp ), 1 )
203 jpvt( i ) = jpvt( itemp )
204 jpvt( itemp ) = i
205 ELSE
206 jpvt( i ) = i
207 END IF
208 itemp = itemp + 1
209 ELSE
210 jpvt( i ) = i
211 END IF
212 10 CONTINUE
213 itemp = itemp - 1
214*
215* Compute the QR factorization and update remaining columns
216*
217 IF( itemp.GT.0 ) THEN
218 ma = min( itemp, m )
219 CALL sgeqr2( m, ma, a, lda, tau, work, info )
220 IF( ma.LT.n ) THEN
221 CALL sorm2r( 'Left', 'Transpose', m, n-ma, ma, a, lda, tau,
222 $ a( 1, ma+1 ), lda, work, info )
223 END IF
224 END IF
225*
226 IF( itemp.LT.mn ) THEN
227*
228* Initialize partial column norms. The first n elements of
229* work store the exact column norms.
230*
231 DO 20 i = itemp + 1, n
232 work( i ) = snrm2( m-itemp, a( itemp+1, i ), 1 )
233 work( n+i ) = work( i )
234 20 CONTINUE
235*
236* Compute factorization
237*
238 DO 40 i = itemp + 1, mn
239*
240* Determine ith pivot column and swap if necessary
241*
242 pvt = ( i-1 ) + isamax( n-i+1, work( i ), 1 )
243*
244 IF( pvt.NE.i ) THEN
245 CALL sswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
246 itemp = jpvt( pvt )
247 jpvt( pvt ) = jpvt( i )
248 jpvt( i ) = itemp
249 work( pvt ) = work( i )
250 work( n+pvt ) = work( n+i )
251 END IF
252*
253* Generate elementary reflector H(i)
254*
255 IF( i.LT.m ) THEN
256 CALL slarfg( m-i+1, a( i, i ), a( i+1, i ), 1, tau( i ) )
257 ELSE
258 CALL slarfg( 1, a( m, m ), a( m, m ), 1, tau( m ) )
259 END IF
260*
261 IF( i.LT.n ) THEN
262*
263* Apply H(i) to A(i:m,i+1:n) from the left
264*
265 aii = a( i, i )
266 a( i, i ) = one
267 CALL slarf( 'LEFT', m-i+1, n-i, a( i, i ), 1, tau( i ),
268 $ a( i, i+1 ), lda, work( 2*n+1 ) )
269 a( i, i ) = aii
270 END IF
271*
272* Update partial column norms
273*
274 DO 30 j = i + 1, n
275 IF( work( j ).NE.zero ) THEN
276*
277* NOTE: The following 4 lines follow from the analysis in
278* Lapack Working Note 176.
279*
280 temp = abs( a( i, j ) ) / work( j )
281 temp = max( zero, ( one+temp )*( one-temp ) )
282 temp2 = temp*( work( j ) / work( n+j ) )**2
283 IF( temp2 .LE. tol3z ) THEN
284 IF( m-i.GT.0 ) THEN
285 work( j ) = snrm2( m-i, a( i+1, j ), 1 )
286 work( n+j ) = work( j )
287 ELSE
288 work( j ) = zero
289 work( n+j ) = zero
290 END IF
291 ELSE
292 work( j ) = work( j )*sqrt( temp )
293 END IF
294 END IF
295 30 CONTINUE
296*
297 40 CONTINUE
298 END IF
299 RETURN
300*
301* End of SGEQPF
302*
sgeqr2
subroutine sgeqr2(m, n, a, lda, tau, work, info)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgeqr2.f:130
sorm2r
subroutine sorm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
Definition sorm2r.f:159

◆ sgeqr2()

subroutine sgeqr2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> SGEQR2 computes a QR factorization of a real m-by-n matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a m-by-m orthogonal matrix;
!>    R is an upper-triangular n-by-n matrix;
!>    0 is a (m-n)-by-n zero matrix, if m > n.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(m,n) by n upper trapezoidal matrix R (R is
!>          upper triangular if m >= n); the elements below the diagonal,
!>          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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>

Definition at line 129 of file sgeqr2.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 INTEGER INFO, LDA, M, N
137* ..
138* .. Array Arguments ..
139 REAL A( LDA, * ), TAU( * ), WORK( * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 REAL ONE
146 parameter( one = 1.0e+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER I, K
150 REAL AII
151* ..
152* .. External Subroutines ..
153 EXTERNAL slarf, slarfg, xerbla
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC max, min
157* ..
158* .. Executable Statements ..
159*
160* Test the input arguments
161*
162 info = 0
163 IF( m.LT.0 ) THEN
164 info = -1
165 ELSE IF( n.LT.0 ) THEN
166 info = -2
167 ELSE IF( lda.LT.max( 1, m ) ) THEN
168 info = -4
169 END IF
170 IF( info.NE.0 ) THEN
171 CALL xerbla( 'SGEQR2', -info )
172 RETURN
173 END IF
174*
175 k = min( m, n )
176*
177 DO 10 i = 1, k
178*
179* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
180*
181 CALL slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
182 $ tau( i ) )
183 IF( i.LT.n ) THEN
184*
185* Apply H(i) to A(i:m,i+1:n) from the left
186*
187 aii = a( i, i )
188 a( i, i ) = one
189 CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
190 $ a( i, i+1 ), lda, work )
191 a( i, i ) = aii
192 END IF
193 10 CONTINUE
194 RETURN
195*
196* End of SGEQR2
197*

◆ sgeqr2p()

subroutine sgeqr2p ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm.

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

Purpose:
!>
!> SGEQR2P computes a QR factorization of a real m-by-n matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a m-by-m orthogonal matrix;
!>    R is an upper-triangular n-by-n matrix with nonnegative diagonal
!>    entries;
!>    0 is a (m-n)-by-n zero matrix, if m > n.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(m,n) by n upper trapezoidal matrix R (R is
!>          upper triangular if m >= n). The diagonal entries of R
!>          are nonnegative; the elements below the diagonal,
!>          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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>
!> See Lapack Working Note 203 for details
!>

Definition at line 133 of file sgeqr2p.f.

134*
135* -- LAPACK computational routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER INFO, LDA, M, N
141* ..
142* .. Array Arguments ..
143 REAL A( LDA, * ), TAU( * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 REAL ONE
150 parameter( one = 1.0e+0 )
151* ..
152* .. Local Scalars ..
153 INTEGER I, K
154 REAL AII
155* ..
156* .. External Subroutines ..
157 EXTERNAL slarf, slarfgp, xerbla
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max, min
161* ..
162* .. Executable Statements ..
163*
164* Test the input arguments
165*
166 info = 0
167 IF( m.LT.0 ) THEN
168 info = -1
169 ELSE IF( n.LT.0 ) THEN
170 info = -2
171 ELSE IF( lda.LT.max( 1, m ) ) THEN
172 info = -4
173 END IF
174 IF( info.NE.0 ) THEN
175 CALL xerbla( 'SGEQR2P', -info )
176 RETURN
177 END IF
178*
179 k = min( m, n )
180*
181 DO 10 i = 1, k
182*
183* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
184*
185 CALL slarfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
186 $ tau( i ) )
187 IF( i.LT.n ) THEN
188*
189* Apply H(i) to A(i:m,i+1:n) from the left
190*
191 aii = a( i, i )
192 a( i, i ) = one
193 CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
194 $ a( i, i+1 ), lda, work )
195 a( i, i ) = aii
196 END IF
197 10 CONTINUE
198 RETURN
199*
200* End of SGEQR2P
201*
slarfgp
subroutine slarfgp(n, alpha, x, incx, tau)
SLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition slarfgp.f:104

◆ sgeqrf()

subroutine sgeqrf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGEQRF

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

Purpose:
!>
!> SGEQRF computes a QR factorization of a real M-by-N matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a M-by-M orthogonal matrix;
!>    R is an upper-triangular N-by-N matrix;
!>    0 is a (M-N)-by-N zero matrix, if M > N.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if m >= n); the elements below the diagonal,
!>          with the array TAU, represent the orthogonal matrix Q as a
!>          product of min(m,n) elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          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, if MIN(M,N) = 0, and LWORK >= N, otherwise.
!>          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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>

Definition at line 145 of file sgeqrf.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 INTEGER INFO, LDA, LWORK, M, N
153* ..
154* .. Array Arguments ..
155 REAL A( LDA, * ), TAU( * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Local Scalars ..
161 LOGICAL LQUERY
162 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
163 $ NBMIN, NX
164* ..
165* .. External Subroutines ..
166 EXTERNAL sgeqr2, slarfb, slarft, xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max, min
170* ..
171* .. External Functions ..
172 INTEGER ILAENV
173 EXTERNAL ilaenv
174* ..
175* .. Executable Statements ..
176*
177* Test the input arguments
178*
179 k = min( m, n )
180 info = 0
181 nb = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 )
182 lquery = ( lwork.EQ.-1 )
183 IF( m.LT.0 ) THEN
184 info = -1
185 ELSE IF( n.LT.0 ) THEN
186 info = -2
187 ELSE IF( lda.LT.max( 1, m ) ) THEN
188 info = -4
189 ELSE IF( .NOT.lquery ) THEN
190 IF( lwork.LE.0 .OR. ( m.GT.0 .AND. lwork.LT.max( 1, n ) ) )
191 $ info = -7
192 END IF
193 IF( info.NE.0 ) THEN
194 CALL xerbla( 'SGEQRF', -info )
195 RETURN
196 ELSE IF( lquery ) THEN
197 IF( k.EQ.0 ) THEN
198 lwkopt = 1
199 ELSE
200 lwkopt = n*nb
201 END IF
202 work( 1 ) = lwkopt
203 RETURN
204 END IF
205*
206* Quick return if possible
207*
208 IF( k.EQ.0 ) THEN
209 work( 1 ) = 1
210 RETURN
211 END IF
212*
213 nbmin = 2
214 nx = 0
215 iws = n
216 IF( nb.GT.1 .AND. nb.LT.k ) THEN
217*
218* Determine when to cross over from blocked to unblocked code.
219*
220 nx = max( 0, ilaenv( 3, 'SGEQRF', ' ', m, n, -1, -1 ) )
221 IF( nx.LT.k ) THEN
222*
223* Determine if workspace is large enough for blocked code.
224*
225 ldwork = n
226 iws = ldwork*nb
227 IF( lwork.LT.iws ) THEN
228*
229* Not enough workspace to use optimal NB: reduce NB and
230* determine the minimum value of NB.
231*
232 nb = lwork / ldwork
233 nbmin = max( 2, ilaenv( 2, 'SGEQRF', ' ', m, n, -1,
234 $ -1 ) )
235 END IF
236 END IF
237 END IF
238*
239 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
240*
241* Use blocked code initially
242*
243 DO 10 i = 1, k - nx, nb
244 ib = min( k-i+1, nb )
245*
246* Compute the QR factorization of the current block
247* A(i:m,i:i+ib-1)
248*
249 CALL sgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,
250 $ iinfo )
251 IF( i+ib.LE.n ) THEN
252*
253* Form the triangular factor of the block reflector
254* H = H(i) H(i+1) . . . H(i+ib-1)
255*
256 CALL slarft( 'Forward', 'Columnwise', m-i+1, ib,
257 $ a( i, i ), lda, tau( i ), work, ldwork )
258*
259* Apply H**T to A(i:m,i+ib:n) from the left
260*
261 CALL slarfb( 'Left', 'Transpose', 'Forward',
262 $ 'Columnwise', m-i+1, n-i-ib+1, ib,
263 $ a( i, i ), lda, work, ldwork, a( i, i+ib ),
264 $ lda, work( ib+1 ), ldwork )
265 END IF
266 10 CONTINUE
267 ELSE
268 i = 1
269 END IF
270*
271* Use unblocked code to factor the last or only block.
272*
273 IF( i.LE.k )
274 $ CALL sgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,
275 $ iinfo )
276*
277 work( 1 ) = iws
278 RETURN
279*
280* End of SGEQRF
281*

◆ sgeqrfp()

subroutine sgeqrfp ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGEQRFP

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

Purpose:
!>
!> SGEQR2P computes a QR factorization of a real M-by-N matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a M-by-M orthogonal matrix;
!>    R is an upper-triangular N-by-N matrix with nonnegative diagonal
!>    entries;
!>    0 is a (M-N)-by-N zero matrix, if M > N.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if m >= n). The diagonal entries of R
!>          are nonnegative; the elements below the diagonal,
!>          with the array TAU, represent the orthogonal matrix Q as a
!>          product of min(m,n) elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          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 >= max(1,N).
!>          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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>
!> See Lapack Working Note 203 for details
!>

Definition at line 148 of file sgeqrfp.f.

149*
150* -- LAPACK computational routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER INFO, LDA, LWORK, M, N
156* ..
157* .. Array Arguments ..
158 REAL A( LDA, * ), TAU( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Local Scalars ..
164 LOGICAL LQUERY
165 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
166 $ NBMIN, NX
167* ..
168* .. External Subroutines ..
169 EXTERNAL sgeqr2p, slarfb, slarft, xerbla
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC max, min
173* ..
174* .. External Functions ..
175 INTEGER ILAENV
176 EXTERNAL ilaenv
177* ..
178* .. Executable Statements ..
179*
180* Test the input arguments
181*
182 info = 0
183 nb = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 )
184 lwkopt = n*nb
185 work( 1 ) = lwkopt
186 lquery = ( lwork.EQ.-1 )
187 IF( m.LT.0 ) THEN
188 info = -1
189 ELSE IF( n.LT.0 ) THEN
190 info = -2
191 ELSE IF( lda.LT.max( 1, m ) ) THEN
192 info = -4
193 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
194 info = -7
195 END IF
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'SGEQRFP', -info )
198 RETURN
199 ELSE IF( lquery ) THEN
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 k = min( m, n )
206 IF( k.EQ.0 ) THEN
207 work( 1 ) = 1
208 RETURN
209 END IF
210*
211 nbmin = 2
212 nx = 0
213 iws = n
214 IF( nb.GT.1 .AND. nb.LT.k ) THEN
215*
216* Determine when to cross over from blocked to unblocked code.
217*
218 nx = max( 0, ilaenv( 3, 'SGEQRF', ' ', m, n, -1, -1 ) )
219 IF( nx.LT.k ) THEN
220*
221* Determine if workspace is large enough for blocked code.
222*
223 ldwork = n
224 iws = ldwork*nb
225 IF( lwork.LT.iws ) THEN
226*
227* Not enough workspace to use optimal NB: reduce NB and
228* determine the minimum value of NB.
229*
230 nb = lwork / ldwork
231 nbmin = max( 2, ilaenv( 2, 'SGEQRF', ' ', m, n, -1,
232 $ -1 ) )
233 END IF
234 END IF
235 END IF
236*
237 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
238*
239* Use blocked code initially
240*
241 DO 10 i = 1, k - nx, nb
242 ib = min( k-i+1, nb )
243*
244* Compute the QR factorization of the current block
245* A(i:m,i:i+ib-1)
246*
247 CALL sgeqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,
248 $ iinfo )
249 IF( i+ib.LE.n ) THEN
250*
251* Form the triangular factor of the block reflector
252* H = H(i) H(i+1) . . . H(i+ib-1)
253*
254 CALL slarft( 'Forward', 'Columnwise', m-i+1, ib,
255 $ a( i, i ), lda, tau( i ), work, ldwork )
256*
257* Apply H**T to A(i:m,i+ib:n) from the left
258*
259 CALL slarfb( 'Left', 'Transpose', 'Forward',
260 $ 'Columnwise', m-i+1, n-i-ib+1, ib,
261 $ a( i, i ), lda, work, ldwork, a( i, i+ib ),
262 $ lda, work( ib+1 ), ldwork )
263 END IF
264 10 CONTINUE
265 ELSE
266 i = 1
267 END IF
268*
269* Use unblocked code to factor the last or only block.
270*
271 IF( i.LE.k )
272 $ CALL sgeqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,
273 $ iinfo )
274*
275 work( 1 ) = iws
276 RETURN
277*
278* End of SGEQRFP
279*
sgeqr2p
subroutine sgeqr2p(m, n, a, lda, tau, work, info)
SGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition sgeqr2p.f:134

◆ sgeqrt()

subroutine sgeqrt ( integer m,
integer n,
integer nb,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( * ) work,
integer info )

SGEQRT

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

Purpose:
!>
!> SGEQRT computes a blocked QR factorization of a real M-by-N matrix A
!> using the compact WY representation of Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= NB >= 1.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if M >= N); the elements below the diagonal
!>          are the columns of V.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is REAL array, dimension (LDT,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[out]WORK
!>          WORK is REAL array, dimension (NB*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.
Further Details:
!>
!>  The matrix V stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1       )
!>                   ( v1  1    )
!>                   ( v1 v2  1 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
!>
!>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/NB), where each
!>  block is of order NB except for the last block, which is of order
!>  IB = K - (B-1)*NB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The NB-by-NB (and IB-by-IB
!>  for the last block) T's are stored in the NB-by-K matrix T as
!>
!>               T = (T1 T2 ... TB).
!>

Definition at line 140 of file sgeqrt.f.

141*
142* -- LAPACK computational routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146* .. Scalar Arguments ..
147 INTEGER INFO, LDA, LDT, M, N, NB
148* ..
149* .. Array Arguments ..
150 REAL A( LDA, * ), T( LDT, * ), WORK( * )
151* ..
152*
153* =====================================================================
154*
155* ..
156* .. Local Scalars ..
157 INTEGER I, IB, IINFO, K
158 LOGICAL USE_RECURSIVE_QR
159 parameter( use_recursive_qr=.true. )
160* ..
161* .. External Subroutines ..
162 EXTERNAL sgeqrt2, sgeqrt3, slarfb, xerbla
163* ..
164* .. Executable Statements ..
165*
166* Test the input arguments
167*
168 info = 0
169 IF( m.LT.0 ) THEN
170 info = -1
171 ELSE IF( n.LT.0 ) THEN
172 info = -2
173 ELSE IF( nb.LT.1 .OR. ( nb.GT.min(m,n) .AND. min(m,n).GT.0 ) )THEN
174 info = -3
175 ELSE IF( lda.LT.max( 1, m ) ) THEN
176 info = -5
177 ELSE IF( ldt.LT.nb ) THEN
178 info = -7
179 END IF
180 IF( info.NE.0 ) THEN
181 CALL xerbla( 'SGEQRT', -info )
182 RETURN
183 END IF
184*
185* Quick return if possible
186*
187 k = min( m, n )
188 IF( k.EQ.0 ) RETURN
189*
190* Blocked loop of length K
191*
192 DO i = 1, k, nb
193 ib = min( k-i+1, nb )
194*
195* Compute the QR factorization of the current block A(I:M,I:I+IB-1)
196*
197 IF( use_recursive_qr ) THEN
198 CALL sgeqrt3( m-i+1, ib, a(i,i), lda, t(1,i), ldt, iinfo )
199 ELSE
200 CALL sgeqrt2( m-i+1, ib, a(i,i), lda, t(1,i), ldt, iinfo )
201 END IF
202 IF( i+ib.LE.n ) THEN
203*
204* Update by applying H**T to A(I:M,I+IB:N) from the left
205*
206 CALL slarfb( 'L', 'T', 'F', 'C', m-i+1, n-i-ib+1, ib,
207 $ a( i, i ), lda, t( 1, i ), ldt,
208 $ a( i, i+ib ), lda, work , n-i-ib+1 )
209 END IF
210 END DO
211 RETURN
212*
213* End of SGEQRT
214*
sgeqrt3
recursive subroutine sgeqrt3(m, n, a, lda, t, ldt, info)
SGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition sgeqrt3.f:132
sgeqrt2
subroutine sgeqrt2(m, n, a, lda, t, ldt, info)
SGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition sgeqrt2.f:127

◆ sgeqrt2()

subroutine sgeqrt2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldt, * ) t,
integer ldt,
integer info )

SGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.

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

Purpose:
!>
!> SGEQRT2 computes a QR factorization of a real M-by-N matrix A,
!> using the compact WY representation of Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the real M-by-N matrix A.  On exit, the elements on and
!>          above the diagonal contain the N-by-N upper triangular matrix R; the
!>          elements below the diagonal are the columns of V.  See below for
!>          further details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is REAL array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= 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.
Further Details:
!>
!>  The matrix V stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1       )
!>                   ( v1  1    )
!>                   ( v1 v2  1 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>

Definition at line 126 of file sgeqrt2.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 INTEGER INFO, LDA, LDT, M, N
134* ..
135* .. Array Arguments ..
136 REAL A( LDA, * ), T( LDT, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ONE, ZERO
143 parameter( one = 1.0, zero = 0.0 )
144* ..
145* .. Local Scalars ..
146 INTEGER I, K
147 REAL AII, ALPHA
148* ..
149* .. External Subroutines ..
150 EXTERNAL slarfg, sgemv, sger, strmv, xerbla
151* ..
152* .. Executable Statements ..
153*
154* Test the input arguments
155*
156 info = 0
157 IF( n.LT.0 ) THEN
158 info = -2
159 ELSE IF( m.LT.n ) THEN
160 info = -1
161 ELSE IF( lda.LT.max( 1, m ) ) THEN
162 info = -4
163 ELSE IF( ldt.LT.max( 1, n ) ) THEN
164 info = -6
165 END IF
166 IF( info.NE.0 ) THEN
167 CALL xerbla( 'SGEQRT2', -info )
168 RETURN
169 END IF
170*
171 k = min( m, n )
172*
173 DO i = 1, k
174*
175* Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1)
176*
177 CALL slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
178 $ t( i, 1 ) )
179 IF( i.LT.n ) THEN
180*
181* Apply H(i) to A(I:M,I+1:N) from the left
182*
183 aii = a( i, i )
184 a( i, i ) = one
185*
186* W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)]
187*
188 CALL sgemv( 'T',m-i+1, n-i, one, a( i, i+1 ), lda,
189 $ a( i, i ), 1, zero, t( 1, n ), 1 )
190*
191* A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H
192*
193 alpha = -(t( i, 1 ))
194 CALL sger( m-i+1, n-i, alpha, a( i, i ), 1,
195 $ t( 1, n ), 1, a( i, i+1 ), lda )
196 a( i, i ) = aii
197 END IF
198 END DO
199*
200 DO i = 2, n
201 aii = a( i, i )
202 a( i, i ) = one
203*
204* T(1:I-1,I) := alpha * A(I:M,1:I-1)**T * A(I:M,I)
205*
206 alpha = -t( i, 1 )
207 CALL sgemv( 'T', m-i+1, i-1, alpha, a( i, 1 ), lda,
208 $ a( i, i ), 1, zero, t( 1, i ), 1 )
209 a( i, i ) = aii
210*
211* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I)
212*
213 CALL strmv( 'U', 'N', 'N', i-1, t, ldt, t( 1, i ), 1 )
214*
215* T(I,I) = tau(I)
216*
217 t( i, i ) = t( i, 1 )
218 t( i, 1) = zero
219 END DO
220
221*
222* End of SGEQRT2
223*
alpha
#define alpha
Definition eval.h:35
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
strmv
subroutine strmv(uplo, trans, diag, n, a, lda, x, incx)
STRMV
Definition strmv.f:147
sger
subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
SGER
Definition sger.f:130

◆ sgeqrt3()

recursive subroutine sgeqrt3 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldt, * ) t,
integer ldt,
integer info )

SGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.

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

Purpose:
!>
!> SGEQRT3 recursively computes a QR factorization of a real M-by-N
!> matrix A, using the compact WY representation of Q.
!>
!> Based on the algorithm of Elmroth and Gustavson,
!> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the real M-by-N matrix A.  On exit, the elements on and
!>          above the diagonal contain the N-by-N upper triangular matrix R; the
!>          elements below the diagonal are the columns of V.  See below for
!>          further details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is REAL array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= 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.
Further Details:
!>
!>  The matrix V stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1       )
!>                   ( v1  1    )
!>                   ( v1 v2  1 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 131 of file sgeqrt3.f.

132*
133* -- LAPACK computational routine --
134* -- LAPACK is a software package provided by Univ. of Tennessee, --
135* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136*
137* .. Scalar Arguments ..
138 INTEGER INFO, LDA, M, N, LDT
139* ..
140* .. Array Arguments ..
141 REAL A( LDA, * ), T( LDT, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 REAL ONE
148 parameter( one = 1.0 )
149* ..
150* .. Local Scalars ..
151 INTEGER I, I1, J, J1, N1, N2, IINFO
152* ..
153* .. External Subroutines ..
154 EXTERNAL slarfg, strmm, sgemm, xerbla
155* ..
156* .. Executable Statements ..
157*
158 info = 0
159 IF( n .LT. 0 ) THEN
160 info = -2
161 ELSE IF( m .LT. n ) THEN
162 info = -1
163 ELSE IF( lda .LT. max( 1, m ) ) THEN
164 info = -4
165 ELSE IF( ldt .LT. max( 1, n ) ) THEN
166 info = -6
167 END IF
168 IF( info.NE.0 ) THEN
169 CALL xerbla( 'SGEQRT3', -info )
170 RETURN
171 END IF
172*
173 IF( n.EQ.1 ) THEN
174*
175* Compute Householder transform when N=1
176*
177 CALL slarfg( m, a(1,1), a( min( 2, m ), 1 ), 1, t(1,1) )
178*
179 ELSE
180*
181* Otherwise, split A into blocks...
182*
183 n1 = n/2
184 n2 = n-n1
185 j1 = min( n1+1, n )
186 i1 = min( n+1, m )
187*
188* Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
189*
190 CALL sgeqrt3( m, n1, a, lda, t, ldt, iinfo )
191*
192* Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)]
193*
194 DO j=1,n2
195 DO i=1,n1
196 t( i, j+n1 ) = a( i, j+n1 )
197 END DO
198 END DO
199 CALL strmm( 'L', 'L', 'T', 'U', n1, n2, one,
200 & a, lda, t( 1, j1 ), ldt )
201*
202 CALL sgemm( 'T', 'N', n1, n2, m-n1, one, a( j1, 1 ), lda,
203 & a( j1, j1 ), lda, one, t( 1, j1 ), ldt)
204*
205 CALL strmm( 'L', 'U', 'T', 'N', n1, n2, one,
206 & t, ldt, t( 1, j1 ), ldt )
207*
208 CALL sgemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1 ), lda,
209 & t( 1, j1 ), ldt, one, a( j1, j1 ), lda )
210*
211 CALL strmm( 'L', 'L', 'N', 'U', n1, n2, one,
212 & a, lda, t( 1, j1 ), ldt )
213*
214 DO j=1,n2
215 DO i=1,n1
216 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 )
217 END DO
218 END DO
219*
220* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
221*
222 CALL sgeqrt3( m-n1, n2, a( j1, j1 ), lda,
223 & t( j1, j1 ), ldt, iinfo )
224*
225* Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2
226*
227 DO i=1,n1
228 DO j=1,n2
229 t( i, j+n1 ) = (a( j+n1, i ))
230 END DO
231 END DO
232*
233 CALL strmm( 'R', 'L', 'N', 'U', n1, n2, one,
234 & a( j1, j1 ), lda, t( 1, j1 ), ldt )
235*
236 CALL sgemm( 'T', 'N', n1, n2, m-n, one, a( i1, 1 ), lda,
237 & a( i1, j1 ), lda, one, t( 1, j1 ), ldt )
238*
239 CALL strmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,
240 & t( 1, j1 ), ldt )
241*
242 CALL strmm( 'R', 'U', 'N', 'N', n1, n2, one,
243 & t( j1, j1 ), ldt, t( 1, j1 ), ldt )
244*
245* Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3]
246* [ 0 R2 ] [ 0 T2]
247*
248 END IF
249*
250 RETURN
251*
252* End of SGEQRT3
253*

◆ sgerfs()

subroutine sgerfs ( character trans,
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 )

SGERFS

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

Purpose:
!>
!> SGERFS improves the computed solution to a system of linear
!> equations and provides error bounds and backward error estimates for
!> the solution.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!>
[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 original 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 factors L and U from the factorization A = P*L*U
!>          as computed by SGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>          The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from SGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[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]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 183 of file sgerfs.f.

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

◆ sgerfsx()

subroutine sgerfsx ( character trans,
character equed,
integer n,
integer nrhs,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
real, dimension( * ) r,
real, dimension( * ) c,
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 )

SGERFSX

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

Purpose:
!>
!>    SGERFSX improves the computed solution to a system of linear
!>    equations 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, R
!>    and C 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]TRANS
!>          TRANS is CHARACTER*1
!>     Specifies the form of the system of equations:
!>       = 'N':  A * X = B     (No transpose)
!>       = 'T':  A**T * X = B  (Transpose)
!>       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!>
[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
!>       = 'R':  Row equilibration, i.e., A has been premultiplied by
!>               diag(R).
!>       = 'C':  Column equilibration, i.e., A has been postmultiplied
!>               by diag(C).
!>       = 'B':  Both row and column equilibration, i.e., A has been
!>               replaced by diag(R) * A * diag(C).
!>               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 original 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 factors L and U from the factorization A = P*L*U
!>     as computed by SGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from SGETRF; for 1<=i<=N, row i of the
!>     matrix was interchanged with row IPIV(i).
!>
[in]R
!>          R is REAL array, dimension (N)
!>     The row scale factors for A.  If EQUED = 'R' or 'B', A is
!>     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!>     is not accessed.
!>     If R is accessed, each element of R 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]C
!>          C is REAL array, dimension (N)
!>     The column scale factors for A.  If EQUED = 'C' or 'B', A is
!>     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!>     is not accessed.
!>     If C is accessed, 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]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 410 of file sgerfsx.f.

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

◆ sgerq2()

subroutine sgerq2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> SGERQ2 computes an RQ factorization of a real m by n matrix A:
!> A = R * Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, if m <= n, the upper triangle of the subarray
!>          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
!>          if m >= n, the elements on and above the (m-n)-th subdiagonal
!>          contain the m by n upper trapezoidal matrix R; the remaining
!>          elements, 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,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is REAL array, dimension (M)
!>
[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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
!>  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
!>

Definition at line 122 of file sgerq2.f.

123*
124* -- LAPACK computational routine --
125* -- LAPACK is a software package provided by Univ. of Tennessee, --
126* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
127*
128* .. Scalar Arguments ..
129 INTEGER INFO, LDA, M, N
130* ..
131* .. Array Arguments ..
132 REAL A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 REAL ONE
139 parameter( one = 1.0e+0 )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 REAL AII
144* ..
145* .. External Subroutines ..
146 EXTERNAL slarf, slarfg, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC max, min
150* ..
151* .. Executable Statements ..
152*
153* Test the input arguments
154*
155 info = 0
156 IF( m.LT.0 ) THEN
157 info = -1
158 ELSE IF( n.LT.0 ) THEN
159 info = -2
160 ELSE IF( lda.LT.max( 1, m ) ) THEN
161 info = -4
162 END IF
163 IF( info.NE.0 ) THEN
164 CALL xerbla( 'SGERQ2', -info )
165 RETURN
166 END IF
167*
168 k = min( m, n )
169*
170 DO 10 i = k, 1, -1
171*
172* Generate elementary reflector H(i) to annihilate
173* A(m-k+i,1:n-k+i-1)
174*
175 CALL slarfg( n-k+i, a( m-k+i, n-k+i ), a( m-k+i, 1 ), lda,
176 $ tau( i ) )
177*
178* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
179*
180 aii = a( m-k+i, n-k+i )
181 a( m-k+i, n-k+i ) = one
182 CALL slarf( 'Right', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,
183 $ tau( i ), a, lda, work )
184 a( m-k+i, n-k+i ) = aii
185 10 CONTINUE
186 RETURN
187*
188* End of SGERQ2
189*

◆ sgerqf()

subroutine sgerqf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

SGERQF

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

Purpose:
!>
!> SGERQF computes an RQ factorization of a real M-by-N matrix A:
!> A = R * Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          if m <= n, the upper triangle of the subarray
!>          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
!>          if m >= n, the elements on and above the (m-n)-th subdiagonal
!>          contain the M-by-N upper trapezoidal matrix R;
!>          the remaining elements, with the array TAU, represent the
!>          orthogonal matrix Q as a product of min(m,n) elementary
!>          reflectors (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is REAL array, dimension (min(M,N))
!>          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, if MIN(M,N) = 0, and LWORK >= M, otherwise.
!>          For optimum performance LWORK >= M*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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
!>  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
!>

Definition at line 138 of file sgerqf.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 INTEGER INFO, LDA, LWORK, M, N
146* ..
147* .. Array Arguments ..
148 REAL A( LDA, * ), TAU( * ), WORK( * )
149* ..
150*
151* =====================================================================
152*
153* .. Local Scalars ..
154 LOGICAL LQUERY
155 INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
156 $ MU, NB, NBMIN, NU, NX
157* ..
158* .. External Subroutines ..
159 EXTERNAL sgerq2, slarfb, slarft, xerbla
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max, min
163* ..
164* .. External Functions ..
165 INTEGER ILAENV
166 EXTERNAL ilaenv
167* ..
168* .. Executable Statements ..
169*
170* Test the input arguments
171*
172 info = 0
173 lquery = ( lwork.EQ.-1 )
174 IF( m.LT.0 ) THEN
175 info = -1
176 ELSE IF( n.LT.0 ) THEN
177 info = -2
178 ELSE IF( lda.LT.max( 1, m ) ) THEN
179 info = -4
180 END IF
181*
182 IF( info.EQ.0 ) THEN
183 k = min( m, n )
184 IF( k.EQ.0 ) THEN
185 lwkopt = 1
186 ELSE
187 nb = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 )
188 lwkopt = m*nb
189 END IF
190 work( 1 ) = lwkopt
191*
192 IF ( .NOT.lquery ) THEN
193 IF( lwork.LE.0 .OR. ( n.GT.0 .AND. lwork.LT.max( 1, m ) ) )
194 $ info = -7
195 END IF
196 END IF
197*
198 IF( info.NE.0 ) THEN
199 CALL xerbla( 'SGERQF', -info )
200 RETURN
201 ELSE IF( lquery ) THEN
202 RETURN
203 END IF
204*
205* Quick return if possible
206*
207 IF( k.EQ.0 ) THEN
208 RETURN
209 END IF
210*
211 nbmin = 2
212 nx = 1
213 iws = m
214 IF( nb.GT.1 .AND. nb.LT.k ) THEN
215*
216* Determine when to cross over from blocked to unblocked code.
217*
218 nx = max( 0, ilaenv( 3, 'SGERQF', ' ', m, n, -1, -1 ) )
219 IF( nx.LT.k ) THEN
220*
221* Determine if workspace is large enough for blocked code.
222*
223 ldwork = m
224 iws = ldwork*nb
225 IF( lwork.LT.iws ) THEN
226*
227* Not enough workspace to use optimal NB: reduce NB and
228* determine the minimum value of NB.
229*
230 nb = lwork / ldwork
231 nbmin = max( 2, ilaenv( 2, 'SGERQF', ' ', m, n, -1,
232 $ -1 ) )
233 END IF
234 END IF
235 END IF
236*
237 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
238*
239* Use blocked code initially.
240* The last kk rows are handled by the block method.
241*
242 ki = ( ( k-nx-1 ) / nb )*nb
243 kk = min( k, ki+nb )
244*
245 DO 10 i = k - kk + ki + 1, k - kk + 1, -nb
246 ib = min( k-i+1, nb )
247*
248* Compute the RQ factorization of the current block
249* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
250*
251 CALL sgerq2( ib, n-k+i+ib-1, a( m-k+i, 1 ), lda, tau( i ),
252 $ work, iinfo )
253 IF( m-k+i.GT.1 ) THEN
254*
255* Form the triangular factor of the block reflector
256* H = H(i+ib-1) . . . H(i+1) H(i)
257*
258 CALL slarft( 'Backward', 'Rowwise', n-k+i+ib-1, ib,
259 $ a( m-k+i, 1 ), lda, tau( i ), work, ldwork )
260*
261* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
262*
263 CALL slarfb( 'Right', 'No transpose', 'Backward',
264 $ 'Rowwise', m-k+i-1, n-k+i+ib-1, ib,
265 $ a( m-k+i, 1 ), lda, work, ldwork, a, lda,
266 $ work( ib+1 ), ldwork )
267 END IF
268 10 CONTINUE
269 mu = m - k + i + nb - 1
270 nu = n - k + i + nb - 1
271 ELSE
272 mu = m
273 nu = n
274 END IF
275*
276* Use unblocked code to factor the last or only block
277*
278 IF( mu.GT.0 .AND. nu.GT.0 )
279 $ CALL sgerq2( mu, nu, a, lda, tau, work, iinfo )
280*
281 work( 1 ) = iws
282 RETURN
283*
284* End of SGERQF
285*
sgerq2
subroutine sgerq2(m, n, a, lda, tau, work, info)
SGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgerq2.f:123

◆ sgesvj()

subroutine sgesvj ( character*1 joba,
character*1 jobu,
character*1 jobv,
integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( n ) sva,
integer mv,
real, dimension( ldv, * ) v,
integer ldv,
real, dimension( lwork ) work,
integer lwork,
integer info )

SGESVJ

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

Purpose:
!>
!> SGESVJ computes the singular value decomposition (SVD) of a real
!> M-by-N matrix A, where M >= N. The SVD of A is written as
!>                                    [++]   [xx]   [x0]   [xx]
!>              A = U * SIGMA * V^t,  [++] = [xx] * [ox] * [xx]
!>                                    [++]   [xx]
!> where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal
!> matrix, and V is an N-by-N orthogonal matrix. The diagonal elements
!> of SIGMA are the singular values of A. The columns of U and V are the
!> left and the right singular vectors of A, respectively.
!> SGESVJ can sometimes compute tiny singular values and their singular vectors much
!> more accurately than other SVD routines, see below under Further Details.
!>
Parameters
[in]JOBA
!>          JOBA is CHARACTER*1
!>          Specifies the structure of A.
!>          = 'L': The input matrix A is lower triangular;
!>          = 'U': The input matrix A is upper triangular;
!>          = 'G': The input matrix A is general M-by-N matrix, M >= N.
!>
[in]JOBU
!>          JOBU is CHARACTER*1
!>          Specifies whether to compute the left singular vectors
!>          (columns of U):
!>          = 'U': The left singular vectors corresponding to the nonzero
!>                 singular values are computed and returned in the leading
!>                 columns of A. See more details in the description of A.
!>                 The default numerical orthogonality threshold is set to
!>                 approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E').
!>          = 'C': Analogous to JOBU='U', except that user can control the
!>                 level of numerical orthogonality of the computed left
!>                 singular vectors. TOL can be set to TOL = CTOL*EPS, where
!>                 CTOL is given on input in the array WORK.
!>                 No CTOL smaller than ONE is allowed. CTOL greater
!>                 than 1 / EPS is meaningless. The option 'C'
!>                 can be used if M*EPS is satisfactory orthogonality
!>                 of the computed left singular vectors, so CTOL=M could
!>                 save few sweeps of Jacobi rotations.
!>                 See the descriptions of A and WORK(1).
!>          = 'N': The matrix U is not computed. However, see the
!>                 description of A.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          Specifies whether to compute the right singular vectors, that
!>          is, the matrix V:
!>          = 'V':  the matrix V is computed and returned in the array V
!>          = 'A':  the Jacobi rotations are applied to the MV-by-N
!>                  array V. In other words, the right singular vector
!>                  matrix V is not computed explicitly; instead it is
!>                  applied to an MV-by-N matrix initially stored in the
!>                  first MV rows of V.
!>          = 'N':  the matrix V is not computed and the array V is not
!>                  referenced
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the input matrix A. 1/SLAMCH('E') > M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the input matrix A.
!>          M >= N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          If JOBU = 'U' .OR. JOBU = 'C':
!>                 If INFO = 0:
!>                 RANKA orthonormal columns of U are returned in the
!>                 leading RANKA columns of the array A. Here RANKA <= N
!>                 is the number of computed singular values of A that are
!>                 above the underflow threshold SLAMCH('S'). The singular
!>                 vectors corresponding to underflowed or zero singular
!>                 values are not computed. The value of RANKA is returned
!>                 in the array WORK as RANKA=NINT(WORK(2)). Also see the
!>                 descriptions of SVA and WORK. The computed columns of U
!>                 are mutually numerically orthogonal up to approximately
!>                 TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU = 'C'),
!>                 see the description of JOBU.
!>                 If INFO > 0,
!>                 the procedure SGESVJ did not converge in the given number
!>                 of iterations (sweeps). In that case, the computed
!>                 columns of U may not be orthogonal up to TOL. The output
!>                 U (stored in A), SIGMA (given by the computed singular
!>                 values in SVA(1:N)) and V is still a decomposition of the
!>                 input matrix A in the sense that the residual
!>                 ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
!>          If JOBU = 'N':
!>                 If INFO = 0:
!>                 Note that the left singular vectors are 'for free' in the
!>                 one-sided Jacobi SVD algorithm. However, if only the
!>                 singular values are needed, the level of numerical
!>                 orthogonality of U is not an issue and iterations are
!>                 stopped when the columns of the iterated matrix are
!>                 numerically orthogonal up to approximately M*EPS. Thus,
!>                 on exit, A contains the columns of U scaled with the
!>                 corresponding singular values.
!>                 If INFO > 0:
!>                 the procedure SGESVJ did not converge in the given number
!>                 of iterations (sweeps).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]SVA
!>          SVA is REAL array, dimension (N)
!>          On exit,
!>          If INFO = 0 :
!>          depending on the value SCALE = WORK(1), we have:
!>                 If SCALE = ONE:
!>                 SVA(1:N) contains the computed singular values of A.
!>                 During the computation SVA contains the Euclidean column
!>                 norms of the iterated matrices in the array A.
!>                 If SCALE .NE. ONE:
!>                 The singular values of A are SCALE*SVA(1:N), and this
!>                 factored representation is due to the fact that some of the
!>                 singular values of A might underflow or overflow.
!>
!>          If INFO > 0 :
!>          the procedure SGESVJ did not converge in the given number of
!>          iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
!>
[in]MV
!>          MV is INTEGER
!>          If JOBV = 'A', then the product of Jacobi rotations in SGESVJ
!>          is applied to the first MV rows of V. See the description of JOBV.
!>
[in,out]V
!>          V is REAL array, dimension (LDV,N)
!>          If JOBV = 'V', then V contains on exit the N-by-N matrix of
!>                         the right singular vectors;
!>          If JOBV = 'A', then V contains the product of the computed right
!>                         singular vector matrix and the initial matrix in
!>                         the array V.
!>          If JOBV = 'N', then V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V, LDV >= 1.
!>          If JOBV = 'V', then LDV >= max(1,N).
!>          If JOBV = 'A', then LDV >= max(1,MV) .
!>
[in,out]WORK
!>          WORK is REAL array, dimension (LWORK)
!>          On entry,
!>          If JOBU = 'C' :
!>          WORK(1) = CTOL, where CTOL defines the threshold for convergence.
!>                    The process stops if all columns of A are mutually
!>                    orthogonal up to CTOL*EPS, EPS=SLAMCH('E').
!>                    It is required that CTOL >= ONE, i.e. it is not
!>                    allowed to force the routine to obtain orthogonality
!>                    below EPSILON.
!>          On exit,
!>          WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
!>                    are the computed singular vcalues of A.
!>                    (See description of SVA().)
!>          WORK(2) = NINT(WORK(2)) is the number of the computed nonzero
!>                    singular values.
!>          WORK(3) = NINT(WORK(3)) is the number of the computed singular
!>                    values that are larger than the underflow threshold.
!>          WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi
!>                    rotations needed for numerical convergence.
!>          WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
!>                    This is useful information in cases when SGESVJ did
!>                    not converge, as it can be used to estimate whether
!>                    the output is still useful and for post festum analysis.
!>          WORK(6) = the largest absolute value over all sines of the
!>                    Jacobi rotation angles in the last sweep. It can be
!>                    useful for a post festum analysis.
!>
[in]LWORK
!>          LWORK is INTEGER
!>         length of WORK, WORK >= MAX(6,M+N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, then the i-th argument had an illegal value
!>          > 0:  SGESVJ did not converge in the maximal allowed number (30)
!>                of sweeps. The output may still be useful. See the
!>                description of WORK.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane rotations. The rotations are implemented as fast scaled rotations of Anda and Park [1]. In the case of underflow of the Jacobi angle, a modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses column interchanges of de Rijk [2]. The relative accuracy of the computed singular values and the accuracy of the computed singular vectors (in angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. The condition number that determines the accuracy in the full rank case is essentially min_{D=diag} kappa(A*D), where kappa(.) is the spectral condition number. The best performance of this Jacobi SVD procedure is achieved if used in an accelerated version of Drmac and Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. Some tuning parameters (marked with [TP]) are available for the implementer.
The computational range for the nonzero singular values is the machine number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even denormalized singular values can be computed with the corresponding gradual loss of accurate digits.
Contributors:
Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
References:
[1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.
SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.

[2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the singular value decomposition on a vector computer.
SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.

[3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
[4] Z. Drmac: Implementation of Jacobi rotations for accurate singular value computation in floating point arithmetic.
SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.

[5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
LAPACK Working note 169.

[6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
LAPACK Working note 170.

[7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, QSVD, (H,K)-SVD computations.
Department of Mathematics, University of Zagreb, 2008.
Bugs, Examples and Comments:
Please report all bugs and send interesting test examples and comments to drmac.nosp@m.@mat.nosp@m.h.hr. Thank you.

Definition at line 321 of file sgesvj.f.

323*
324* -- LAPACK computational routine --
325* -- LAPACK is a software package provided by Univ. of Tennessee, --
326* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
327*
328* .. Scalar Arguments ..
329 INTEGER INFO, LDA, LDV, LWORK, M, MV, N
330 CHARACTER*1 JOBA, JOBU, JOBV
331* ..
332* .. Array Arguments ..
333 REAL A( LDA, * ), SVA( N ), V( LDV, * ),
334 $ WORK( LWORK )
335* ..
336*
337* =====================================================================
338*
339* .. Local Parameters ..
340 REAL ZERO, HALF, ONE
341 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0)
342 INTEGER NSWEEP
343 parameter( nsweep = 30 )
344* ..
345* .. Local Scalars ..
346 REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
347 $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,
348 $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
349 $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,
350 $ THSIGN, TOL
351 INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
352 $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,
353 $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,
354 $ SWBAND
355 LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
356 $ RSVEC, UCTOL, UPPER
357* ..
358* .. Local Arrays ..
359 REAL FASTR( 5 )
360* ..
361* .. Intrinsic Functions ..
362 INTRINSIC abs, max, min, float, sign, sqrt
363* ..
364* .. External Functions ..
365* ..
366* from BLAS
367 REAL SDOT, SNRM2
368 EXTERNAL sdot, snrm2
369 INTEGER ISAMAX
370 EXTERNAL isamax
371* from LAPACK
372 REAL SLAMCH
373 EXTERNAL slamch
374 LOGICAL LSAME
375 EXTERNAL lsame
376* ..
377* .. External Subroutines ..
378* ..
379* from BLAS
380 EXTERNAL saxpy, scopy, srotm, sscal, sswap
381* from LAPACK
382 EXTERNAL slascl, slaset, slassq, xerbla
383*
384 EXTERNAL sgsvj0, sgsvj1
385* ..
386* .. Executable Statements ..
387*
388* Test the input arguments
389*
390 lsvec = lsame( jobu, 'U' )
391 uctol = lsame( jobu, 'C' )
392 rsvec = lsame( jobv, 'V' )
393 applv = lsame( jobv, 'A' )
394 upper = lsame( joba, 'U' )
395 lower = lsame( joba, 'L' )
396*
397 IF( .NOT.( upper .OR. lower .OR. lsame( joba, 'G' ) ) ) THEN
398 info = -1
399 ELSE IF( .NOT.( lsvec .OR. uctol .OR. lsame( jobu, 'N' ) ) ) THEN
400 info = -2
401 ELSE IF( .NOT.( rsvec .OR. applv .OR. lsame( jobv, 'N' ) ) ) THEN
402 info = -3
403 ELSE IF( m.LT.0 ) THEN
404 info = -4
405 ELSE IF( ( n.LT.0 ) .OR. ( n.GT.m ) ) THEN
406 info = -5
407 ELSE IF( lda.LT.m ) THEN
408 info = -7
409 ELSE IF( mv.LT.0 ) THEN
410 info = -9
411 ELSE IF( ( rsvec .AND. ( ldv.LT.n ) ) .OR.
412 $ ( applv .AND. ( ldv.LT.mv ) ) ) THEN
413 info = -11
414 ELSE IF( uctol .AND. ( work( 1 ).LE.one ) ) THEN
415 info = -12
416 ELSE IF( lwork.LT.max( m+n, 6 ) ) THEN
417 info = -13
418 ELSE
419 info = 0
420 END IF
421*
422* #:(
423 IF( info.NE.0 ) THEN
424 CALL xerbla( 'SGESVJ', -info )
425 RETURN
426 END IF
427*
428* #:) Quick return for void matrix
429*
430 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )RETURN
431*
432* Set numerical parameters
433* The stopping criterion for Jacobi rotations is
434*
435* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS
436*
437* where EPS is the round-off and CTOL is defined as follows:
438*
439 IF( uctol ) THEN
440* ... user controlled
441 ctol = work( 1 )
442 ELSE
443* ... default
444 IF( lsvec .OR. rsvec .OR. applv ) THEN
445 ctol = sqrt( float( m ) )
446 ELSE
447 ctol = float( m )
448 END IF
449 END IF
450* ... and the machine dependent parameters are
451*[!] (Make sure that SLAMCH() works properly on the target machine.)
452*
453 epsln = slamch( 'Epsilon' )
454 rooteps = sqrt( epsln )
455 sfmin = slamch( 'SafeMinimum' )
456 rootsfmin = sqrt( sfmin )
457 small = sfmin / epsln
458 big = slamch( 'Overflow' )
459* BIG = ONE / SFMIN
460 rootbig = one / rootsfmin
461 large = big / sqrt( float( m*n ) )
462 bigtheta = one / rooteps
463*
464 tol = ctol*epsln
465 roottol = sqrt( tol )
466*
467 IF( float( m )*epsln.GE.one ) THEN
468 info = -4
469 CALL xerbla( 'SGESVJ', -info )
470 RETURN
471 END IF
472*
473* Initialize the right singular vector matrix.
474*
475 IF( rsvec ) THEN
476 mvl = n
477 CALL slaset( 'A', mvl, n, zero, one, v, ldv )
478 ELSE IF( applv ) THEN
479 mvl = mv
480 END IF
481 rsvec = rsvec .OR. applv
482*
483* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N )
484*(!) If necessary, scale A to protect the largest singular value
485* from overflow. It is possible that saving the largest singular
486* value destroys the information about the small ones.
487* This initial scaling is almost minimal in the sense that the
488* goal is to make sure that no column norm overflows, and that
489* SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries
490* in A are detected, the procedure returns with INFO=-6.
491*
492 skl = one / sqrt( float( m )*float( n ) )
493 noscale = .true.
494 goscale = .true.
495*
496 IF( lower ) THEN
497* the input matrix is M-by-N lower triangular (trapezoidal)
498 DO 1874 p = 1, n
499 aapp = zero
500 aaqq = one
501 CALL slassq( m-p+1, a( p, p ), 1, aapp, aaqq )
502 IF( aapp.GT.big ) THEN
503 info = -6
504 CALL xerbla( 'SGESVJ', -info )
505 RETURN
506 END IF
507 aaqq = sqrt( aaqq )
508 IF( ( aapp.LT.( big / aaqq ) ) .AND. noscale ) THEN
509 sva( p ) = aapp*aaqq
510 ELSE
511 noscale = .false.
512 sva( p ) = aapp*( aaqq*skl )
513 IF( goscale ) THEN
514 goscale = .false.
515 DO 1873 q = 1, p - 1
516 sva( q ) = sva( q )*skl
517 1873 CONTINUE
518 END IF
519 END IF
520 1874 CONTINUE
521 ELSE IF( upper ) THEN
522* the input matrix is M-by-N upper triangular (trapezoidal)
523 DO 2874 p = 1, n
524 aapp = zero
525 aaqq = one
526 CALL slassq( p, a( 1, p ), 1, aapp, aaqq )
527 IF( aapp.GT.big ) THEN
528 info = -6
529 CALL xerbla( 'SGESVJ', -info )
530 RETURN
531 END IF
532 aaqq = sqrt( aaqq )
533 IF( ( aapp.LT.( big / aaqq ) ) .AND. noscale ) THEN
534 sva( p ) = aapp*aaqq
535 ELSE
536 noscale = .false.
537 sva( p ) = aapp*( aaqq*skl )
538 IF( goscale ) THEN
539 goscale = .false.
540 DO 2873 q = 1, p - 1
541 sva( q ) = sva( q )*skl
542 2873 CONTINUE
543 END IF
544 END IF
545 2874 CONTINUE
546 ELSE
547* the input matrix is M-by-N general dense
548 DO 3874 p = 1, n
549 aapp = zero
550 aaqq = one
551 CALL slassq( m, a( 1, p ), 1, aapp, aaqq )
552 IF( aapp.GT.big ) THEN
553 info = -6
554 CALL xerbla( 'SGESVJ', -info )
555 RETURN
556 END IF
557 aaqq = sqrt( aaqq )
558 IF( ( aapp.LT.( big / aaqq ) ) .AND. noscale ) THEN
559 sva( p ) = aapp*aaqq
560 ELSE
561 noscale = .false.
562 sva( p ) = aapp*( aaqq*skl )
563 IF( goscale ) THEN
564 goscale = .false.
565 DO 3873 q = 1, p - 1
566 sva( q ) = sva( q )*skl
567 3873 CONTINUE
568 END IF
569 END IF
570 3874 CONTINUE
571 END IF
572*
573 IF( noscale )skl = one
574*
575* Move the smaller part of the spectrum from the underflow threshold
576*(!) Start by determining the position of the nonzero entries of the
577* array SVA() relative to ( SFMIN, BIG ).
578*
579 aapp = zero
580 aaqq = big
581 DO 4781 p = 1, n
582 IF( sva( p ).NE.zero )aaqq = min( aaqq, sva( p ) )
583 aapp = max( aapp, sva( p ) )
584 4781 CONTINUE
585*
586* #:) Quick return for zero matrix
587*
588 IF( aapp.EQ.zero ) THEN
589 IF( lsvec )CALL slaset( 'G', m, n, zero, one, a, lda )
590 work( 1 ) = one
591 work( 2 ) = zero
592 work( 3 ) = zero
593 work( 4 ) = zero
594 work( 5 ) = zero
595 work( 6 ) = zero
596 RETURN
597 END IF
598*
599* #:) Quick return for one-column matrix
600*
601 IF( n.EQ.1 ) THEN
602 IF( lsvec )CALL slascl( 'G', 0, 0, sva( 1 ), skl, m, 1,
603 $ a( 1, 1 ), lda, ierr )
604 work( 1 ) = one / skl
605 IF( sva( 1 ).GE.sfmin ) THEN
606 work( 2 ) = one
607 ELSE
608 work( 2 ) = zero
609 END IF
610 work( 3 ) = zero
611 work( 4 ) = zero
612 work( 5 ) = zero
613 work( 6 ) = zero
614 RETURN
615 END IF
616*
617* Protect small singular values from underflow, and try to
618* avoid underflows/overflows in computing Jacobi rotations.
619*
620 sn = sqrt( sfmin / epsln )
621 temp1 = sqrt( big / float( n ) )
622 IF( ( aapp.LE.sn ) .OR. ( aaqq.GE.temp1 ) .OR.
623 $ ( ( sn.LE.aaqq ) .AND. ( aapp.LE.temp1 ) ) ) THEN
624 temp1 = min( big, temp1 / aapp )
625* AAQQ = AAQQ*TEMP1
626* AAPP = AAPP*TEMP1
627 ELSE IF( ( aaqq.LE.sn ) .AND. ( aapp.LE.temp1 ) ) THEN
628 temp1 = min( sn / aaqq, big / ( aapp*sqrt( float( n ) ) ) )
629* AAQQ = AAQQ*TEMP1
630* AAPP = AAPP*TEMP1
631 ELSE IF( ( aaqq.GE.sn ) .AND. ( aapp.GE.temp1 ) ) THEN
632 temp1 = max( sn / aaqq, temp1 / aapp )
633* AAQQ = AAQQ*TEMP1
634* AAPP = AAPP*TEMP1
635 ELSE IF( ( aaqq.LE.sn ) .AND. ( aapp.GE.temp1 ) ) THEN
636 temp1 = min( sn / aaqq, big / ( sqrt( float( n ) )*aapp ) )
637* AAQQ = AAQQ*TEMP1
638* AAPP = AAPP*TEMP1
639 ELSE
640 temp1 = one
641 END IF
642*
643* Scale, if necessary
644*
645 IF( temp1.NE.one ) THEN
646 CALL slascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr )
647 END IF
648 skl = temp1*skl
649 IF( skl.NE.one ) THEN
650 CALL slascl( joba, 0, 0, one, skl, m, n, a, lda, ierr )
651 skl = one / skl
652 END IF
653*
654* Row-cyclic Jacobi SVD algorithm with column pivoting
655*
656 emptsw = ( n*( n-1 ) ) / 2
657 notrot = 0
658 fastr( 1 ) = zero
659*
660* A is represented in factored form A = A * diag(WORK), where diag(WORK)
661* is initialized to identity. WORK is updated during fast scaled
662* rotations.
663*
664 DO 1868 q = 1, n
665 work( q ) = one
666 1868 CONTINUE
667*
668*
669 swband = 3
670*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective
671* if SGESVJ is used as a computational routine in the preconditioned
672* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure
673* works on pivots inside a band-like region around the diagonal.
674* The boundaries are determined dynamically, based on the number of
675* pivots above a threshold.
676*
677 kbl = min( 8, n )
678*[TP] KBL is a tuning parameter that defines the tile size in the
679* tiling of the p-q loops of pivot pairs. In general, an optimal
680* value of KBL depends on the matrix dimensions and on the
681* parameters of the computer's memory.
682*
683 nbl = n / kbl
684 IF( ( nbl*kbl ).NE.n )nbl = nbl + 1
685*
686 blskip = kbl**2
687*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
688*
689 rowskip = min( 5, kbl )
690*[TP] ROWSKIP is a tuning parameter.
691*
692 lkahead = 1
693*[TP] LKAHEAD is a tuning parameter.
694*
695* Quasi block transformations, using the lower (upper) triangular
696* structure of the input matrix. The quasi-block-cycling usually
697* invokes cubic convergence. Big part of this cycle is done inside
698* canonical subspaces of dimensions less than M.
699*
700 IF( ( lower .OR. upper ) .AND. ( n.GT.max( 64, 4*kbl ) ) ) THEN
701*[TP] The number of partition levels and the actual partition are
702* tuning parameters.
703 n4 = n / 4
704 n2 = n / 2
705 n34 = 3*n4
706 IF( applv ) THEN
707 q = 0
708 ELSE
709 q = 1
710 END IF
711*
712 IF( lower ) THEN
713*
714* This works very well on lower triangular matrices, in particular
715* in the framework of the preconditioned Jacobi SVD (xGEJSV).
716* The idea is simple:
717* [+ 0 0 0] Note that Jacobi transformations of [0 0]
718* [+ + 0 0] [0 0]
719* [+ + x 0] actually work on [x 0] [x 0]
720* [+ + x x] [x x]. [x x]
721*
722 CALL sgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,
723 $ work( n34+1 ), sva( n34+1 ), mvl,
724 $ v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,
725 $ 2, work( n+1 ), lwork-n, ierr )
726*
727 CALL sgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,
728 $ work( n2+1 ), sva( n2+1 ), mvl,
729 $ v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,
730 $ work( n+1 ), lwork-n, ierr )
731*
732 CALL sgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,
733 $ work( n2+1 ), sva( n2+1 ), mvl,
734 $ v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,
735 $ work( n+1 ), lwork-n, ierr )
736*
737 CALL sgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,
738 $ work( n4+1 ), sva( n4+1 ), mvl,
739 $ v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,
740 $ work( n+1 ), lwork-n, ierr )
741*
742 CALL sgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,
743 $ epsln, sfmin, tol, 1, work( n+1 ), lwork-n,
744 $ ierr )
745*
746 CALL sgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,
747 $ ldv, epsln, sfmin, tol, 1, work( n+1 ),
748 $ lwork-n, ierr )
749*
750*
751 ELSE IF( upper ) THEN
752*
753*
754 CALL sgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,
755 $ epsln, sfmin, tol, 2, work( n+1 ), lwork-n,
756 $ ierr )
757*
758 CALL sgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),
759 $ sva( n4+1 ), mvl, v( n4*q+1, n4+1 ), ldv,
760 $ epsln, sfmin, tol, 1, work( n+1 ), lwork-n,
761 $ ierr )
762*
763 CALL sgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,
764 $ ldv, epsln, sfmin, tol, 1, work( n+1 ),
765 $ lwork-n, ierr )
766*
767 CALL sgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,
768 $ work( n2+1 ), sva( n2+1 ), mvl,
769 $ v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,
770 $ work( n+1 ), lwork-n, ierr )
771
772 END IF
773*
774 END IF
775*
776* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
777*
778 DO 1993 i = 1, nsweep
779*
780* .. go go go ...
781*
782 mxaapq = zero
783 mxsinj = zero
784 iswrot = 0
785*
786 notrot = 0
787 pskipped = 0
788*
789* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
790* 1 <= p < q <= N. This is the first step toward a blocked implementation
791* of the rotations. New implementation, based on block transformations,
792* is under development.
793*
794 DO 2000 ibr = 1, nbl
795*
796 igl = ( ibr-1 )*kbl + 1
797*
798 DO 1002 ir1 = 0, min( lkahead, nbl-ibr )
799*
800 igl = igl + ir1*kbl
801*
802 DO 2001 p = igl, min( igl+kbl-1, n-1 )
803*
804* .. de Rijk's pivoting
805*
806 q = isamax( n-p+1, sva( p ), 1 ) + p - 1
807 IF( p.NE.q ) THEN
808 CALL sswap( m, a( 1, p ), 1, a( 1, q ), 1 )
809 IF( rsvec )CALL sswap( mvl, v( 1, p ), 1,
810 $ v( 1, q ), 1 )
811 temp1 = sva( p )
812 sva( p ) = sva( q )
813 sva( q ) = temp1
814 temp1 = work( p )
815 work( p ) = work( q )
816 work( q ) = temp1
817 END IF
818*
819 IF( ir1.EQ.0 ) THEN
820*
821* Column norms are periodically updated by explicit
822* norm computation.
823* Caveat:
824* Unfortunately, some BLAS implementations compute SNRM2(M,A(1,p),1)
825* as SQRT(SDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to
826* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and to
827* underflow for ||A(:,p)||_2 < SQRT(underflow_threshold).
828* Hence, SNRM2 cannot be trusted, not even in the case when
829* the true norm is far from the under(over)flow boundaries.
830* If properly implemented SNRM2 is available, the IF-THEN-ELSE
831* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p)".
832*
833 IF( ( sva( p ).LT.rootbig ) .AND.
834 $ ( sva( p ).GT.rootsfmin ) ) THEN
835 sva( p ) = snrm2( m, a( 1, p ), 1 )*work( p )
836 ELSE
837 temp1 = zero
838 aapp = one
839 CALL slassq( m, a( 1, p ), 1, temp1, aapp )
840 sva( p ) = temp1*sqrt( aapp )*work( p )
841 END IF
842 aapp = sva( p )
843 ELSE
844 aapp = sva( p )
845 END IF
846*
847 IF( aapp.GT.zero ) THEN
848*
849 pskipped = 0
850*
851 DO 2002 q = p + 1, min( igl+kbl-1, n )
852*
853 aaqq = sva( q )
854*
855 IF( aaqq.GT.zero ) THEN
856*
857 aapp0 = aapp
858 IF( aaqq.GE.one ) THEN
859 rotok = ( small*aapp ).LE.aaqq
860 IF( aapp.LT.( big / aaqq ) ) THEN
861 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
862 $ q ), 1 )*work( p )*work( q ) /
863 $ aaqq ) / aapp
864 ELSE
865 CALL scopy( m, a( 1, p ), 1,
866 $ work( n+1 ), 1 )
867 CALL slascl( 'G', 0, 0, aapp,
868 $ work( p ), m, 1,
869 $ work( n+1 ), lda, ierr )
870 aapq = sdot( m, work( n+1 ), 1,
871 $ a( 1, q ), 1 )*work( q ) / aaqq
872 END IF
873 ELSE
874 rotok = aapp.LE.( aaqq / small )
875 IF( aapp.GT.( small / aaqq ) ) THEN
876 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
877 $ q ), 1 )*work( p )*work( q ) /
878 $ aaqq ) / aapp
879 ELSE
880 CALL scopy( m, a( 1, q ), 1,
881 $ work( n+1 ), 1 )
882 CALL slascl( 'G', 0, 0, aaqq,
883 $ work( q ), m, 1,
884 $ work( n+1 ), lda, ierr )
885 aapq = sdot( m, work( n+1 ), 1,
886 $ a( 1, p ), 1 )*work( p ) / aapp
887 END IF
888 END IF
889*
890 mxaapq = max( mxaapq, abs( aapq ) )
891*
892* TO rotate or NOT to rotate, THAT is the question ...
893*
894 IF( abs( aapq ).GT.tol ) THEN
895*
896* .. rotate
897*[RTD] ROTATED = ROTATED + ONE
898*
899 IF( ir1.EQ.0 ) THEN
900 notrot = 0
901 pskipped = 0
902 iswrot = iswrot + 1
903 END IF
904*
905 IF( rotok ) THEN
906*
907 aqoap = aaqq / aapp
908 apoaq = aapp / aaqq
909 theta = -half*abs( aqoap-apoaq ) / aapq
910*
911 IF( abs( theta ).GT.bigtheta ) THEN
912*
913 t = half / theta
914 fastr( 3 ) = t*work( p ) / work( q )
915 fastr( 4 ) = -t*work( q ) /
916 $ work( p )
917 CALL srotm( m, a( 1, p ), 1,
918 $ a( 1, q ), 1, fastr )
919 IF( rsvec )CALL srotm( mvl,
920 $ v( 1, p ), 1,
921 $ v( 1, q ), 1,
922 $ fastr )
923 sva( q ) = aaqq*sqrt( max( zero,
924 $ one+t*apoaq*aapq ) )
925 aapp = aapp*sqrt( max( zero,
926 $ one-t*aqoap*aapq ) )
927 mxsinj = max( mxsinj, abs( t ) )
928*
929 ELSE
930*
931* .. choose correct signum for THETA and rotate
932*
933 thsign = -sign( one, aapq )
934 t = one / ( theta+thsign*
935 $ sqrt( one+theta*theta ) )
936 cs = sqrt( one / ( one+t*t ) )
937 sn = t*cs
938*
939 mxsinj = max( mxsinj, abs( sn ) )
940 sva( q ) = aaqq*sqrt( max( zero,
941 $ one+t*apoaq*aapq ) )
942 aapp = aapp*sqrt( max( zero,
943 $ one-t*aqoap*aapq ) )
944*
945 apoaq = work( p ) / work( q )
946 aqoap = work( q ) / work( p )
947 IF( work( p ).GE.one ) THEN
948 IF( work( q ).GE.one ) THEN
949 fastr( 3 ) = t*apoaq
950 fastr( 4 ) = -t*aqoap
951 work( p ) = work( p )*cs
952 work( q ) = work( q )*cs
953 CALL srotm( m, a( 1, p ), 1,
954 $ a( 1, q ), 1,
955 $ fastr )
956 IF( rsvec )CALL srotm( mvl,
957 $ v( 1, p ), 1, v( 1, q ),
958 $ 1, fastr )
959 ELSE
960 CALL saxpy( m, -t*aqoap,
961 $ a( 1, q ), 1,
962 $ a( 1, p ), 1 )
963 CALL saxpy( m, cs*sn*apoaq,
964 $ a( 1, p ), 1,
965 $ a( 1, q ), 1 )
966 work( p ) = work( p )*cs
967 work( q ) = work( q ) / cs
968 IF( rsvec ) THEN
969 CALL saxpy( mvl, -t*aqoap,
970 $ v( 1, q ), 1,
971 $ v( 1, p ), 1 )
972 CALL saxpy( mvl,
973 $ cs*sn*apoaq,
974 $ v( 1, p ), 1,
975 $ v( 1, q ), 1 )
976 END IF
977 END IF
978 ELSE
979 IF( work( q ).GE.one ) THEN
980 CALL saxpy( m, t*apoaq,
981 $ a( 1, p ), 1,
982 $ a( 1, q ), 1 )
983 CALL saxpy( m, -cs*sn*aqoap,
984 $ a( 1, q ), 1,
985 $ a( 1, p ), 1 )
986 work( p ) = work( p ) / cs
987 work( q ) = work( q )*cs
988 IF( rsvec ) THEN
989 CALL saxpy( mvl, t*apoaq,
990 $ v( 1, p ), 1,
991 $ v( 1, q ), 1 )
992 CALL saxpy( mvl,
993 $ -cs*sn*aqoap,
994 $ v( 1, q ), 1,
995 $ v( 1, p ), 1 )
996 END IF
997 ELSE
998 IF( work( p ).GE.work( q ) )
999 $ THEN
1000 CALL saxpy( m, -t*aqoap,
1001 $ a( 1, q ), 1,
1002 $ a( 1, p ), 1 )
1003 CALL saxpy( m, cs*sn*apoaq,
1004 $ a( 1, p ), 1,
1005 $ a( 1, q ), 1 )
1006 work( p ) = work( p )*cs
1007 work( q ) = work( q ) / cs
1008 IF( rsvec ) THEN
1009 CALL saxpy( mvl,
1010 $ -t*aqoap,
1011 $ v( 1, q ), 1,
1012 $ v( 1, p ), 1 )
1013 CALL saxpy( mvl,
1014 $ cs*sn*apoaq,
1015 $ v( 1, p ), 1,
1016 $ v( 1, q ), 1 )
1017 END IF
1018 ELSE
1019 CALL saxpy( m, t*apoaq,
1020 $ a( 1, p ), 1,
1021 $ a( 1, q ), 1 )
1022 CALL saxpy( m,
1023 $ -cs*sn*aqoap,
1024 $ a( 1, q ), 1,
1025 $ a( 1, p ), 1 )
1026 work( p ) = work( p ) / cs
1027 work( q ) = work( q )*cs
1028 IF( rsvec ) THEN
1029 CALL saxpy( mvl,
1030 $ t*apoaq, v( 1, p ),
1031 $ 1, v( 1, q ), 1 )
1032 CALL saxpy( mvl,
1033 $ -cs*sn*aqoap,
1034 $ v( 1, q ), 1,
1035 $ v( 1, p ), 1 )
1036 END IF
1037 END IF
1038 END IF
1039 END IF
1040 END IF
1041*
1042 ELSE
1043* .. have to use modified Gram-Schmidt like transformation
1044 CALL scopy( m, a( 1, p ), 1,
1045 $ work( n+1 ), 1 )
1046 CALL slascl( 'G', 0, 0, aapp, one, m,
1047 $ 1, work( n+1 ), lda,
1048 $ ierr )
1049 CALL slascl( 'G', 0, 0, aaqq, one, m,
1050 $ 1, a( 1, q ), lda, ierr )
1051 temp1 = -aapq*work( p ) / work( q )
1052 CALL saxpy( m, temp1, work( n+1 ), 1,
1053 $ a( 1, q ), 1 )
1054 CALL slascl( 'G', 0, 0, one, aaqq, m,
1055 $ 1, a( 1, q ), lda, ierr )
1056 sva( q ) = aaqq*sqrt( max( zero,
1057 $ one-aapq*aapq ) )
1058 mxsinj = max( mxsinj, sfmin )
1059 END IF
1060* END IF ROTOK THEN ... ELSE
1061*
1062* In the case of cancellation in updating SVA(q), SVA(p)
1063* recompute SVA(q), SVA(p).
1064*
1065 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
1066 $ THEN
1067 IF( ( aaqq.LT.rootbig ) .AND.
1068 $ ( aaqq.GT.rootsfmin ) ) THEN
1069 sva( q ) = snrm2( m, a( 1, q ), 1 )*
1070 $ work( q )
1071 ELSE
1072 t = zero
1073 aaqq = one
1074 CALL slassq( m, a( 1, q ), 1, t,
1075 $ aaqq )
1076 sva( q ) = t*sqrt( aaqq )*work( q )
1077 END IF
1078 END IF
1079 IF( ( aapp / aapp0 ).LE.rooteps ) THEN
1080 IF( ( aapp.LT.rootbig ) .AND.
1081 $ ( aapp.GT.rootsfmin ) ) THEN
1082 aapp = snrm2( m, a( 1, p ), 1 )*
1083 $ work( p )
1084 ELSE
1085 t = zero
1086 aapp = one
1087 CALL slassq( m, a( 1, p ), 1, t,
1088 $ aapp )
1089 aapp = t*sqrt( aapp )*work( p )
1090 END IF
1091 sva( p ) = aapp
1092 END IF
1093*
1094 ELSE
1095* A(:,p) and A(:,q) already numerically orthogonal
1096 IF( ir1.EQ.0 )notrot = notrot + 1
1097*[RTD] SKIPPED = SKIPPED + 1
1098 pskipped = pskipped + 1
1099 END IF
1100 ELSE
1101* A(:,q) is zero column
1102 IF( ir1.EQ.0 )notrot = notrot + 1
1103 pskipped = pskipped + 1
1104 END IF
1105*
1106 IF( ( i.LE.swband ) .AND.
1107 $ ( pskipped.GT.rowskip ) ) THEN
1108 IF( ir1.EQ.0 )aapp = -aapp
1109 notrot = 0
1110 GO TO 2103
1111 END IF
1112*
1113 2002 CONTINUE
1114* END q-LOOP
1115*
1116 2103 CONTINUE
1117* bailed out of q-loop
1118*
1119 sva( p ) = aapp
1120*
1121 ELSE
1122 sva( p ) = aapp
1123 IF( ( ir1.EQ.0 ) .AND. ( aapp.EQ.zero ) )
1124 $ notrot = notrot + min( igl+kbl-1, n ) - p
1125 END IF
1126*
1127 2001 CONTINUE
1128* end of the p-loop
1129* end of doing the block ( ibr, ibr )
1130 1002 CONTINUE
1131* end of ir1-loop
1132*
1133* ... go to the off diagonal blocks
1134*
1135 igl = ( ibr-1 )*kbl + 1
1136*
1137 DO 2010 jbc = ibr + 1, nbl
1138*
1139 jgl = ( jbc-1 )*kbl + 1
1140*
1141* doing the block at ( ibr, jbc )
1142*
1143 ijblsk = 0
1144 DO 2100 p = igl, min( igl+kbl-1, n )
1145*
1146 aapp = sva( p )
1147 IF( aapp.GT.zero ) THEN
1148*
1149 pskipped = 0
1150*
1151 DO 2200 q = jgl, min( jgl+kbl-1, n )
1152*
1153 aaqq = sva( q )
1154 IF( aaqq.GT.zero ) THEN
1155 aapp0 = aapp
1156*
1157* .. M x 2 Jacobi SVD ..
1158*
1159* Safe Gram matrix computation
1160*
1161 IF( aaqq.GE.one ) THEN
1162 IF( aapp.GE.aaqq ) THEN
1163 rotok = ( small*aapp ).LE.aaqq
1164 ELSE
1165 rotok = ( small*aaqq ).LE.aapp
1166 END IF
1167 IF( aapp.LT.( big / aaqq ) ) THEN
1168 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
1169 $ q ), 1 )*work( p )*work( q ) /
1170 $ aaqq ) / aapp
1171 ELSE
1172 CALL scopy( m, a( 1, p ), 1,
1173 $ work( n+1 ), 1 )
1174 CALL slascl( 'G', 0, 0, aapp,
1175 $ work( p ), m, 1,
1176 $ work( n+1 ), lda, ierr )
1177 aapq = sdot( m, work( n+1 ), 1,
1178 $ a( 1, q ), 1 )*work( q ) / aaqq
1179 END IF
1180 ELSE
1181 IF( aapp.GE.aaqq ) THEN
1182 rotok = aapp.LE.( aaqq / small )
1183 ELSE
1184 rotok = aaqq.LE.( aapp / small )
1185 END IF
1186 IF( aapp.GT.( small / aaqq ) ) THEN
1187 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
1188 $ q ), 1 )*work( p )*work( q ) /
1189 $ aaqq ) / aapp
1190 ELSE
1191 CALL scopy( m, a( 1, q ), 1,
1192 $ work( n+1 ), 1 )
1193 CALL slascl( 'G', 0, 0, aaqq,
1194 $ work( q ), m, 1,
1195 $ work( n+1 ), lda, ierr )
1196 aapq = sdot( m, work( n+1 ), 1,
1197 $ a( 1, p ), 1 )*work( p ) / aapp
1198 END IF
1199 END IF
1200*
1201 mxaapq = max( mxaapq, abs( aapq ) )
1202*
1203* TO rotate or NOT to rotate, THAT is the question ...
1204*
1205 IF( abs( aapq ).GT.tol ) THEN
1206 notrot = 0
1207*[RTD] ROTATED = ROTATED + 1
1208 pskipped = 0
1209 iswrot = iswrot + 1
1210*
1211 IF( rotok ) THEN
1212*
1213 aqoap = aaqq / aapp
1214 apoaq = aapp / aaqq
1215 theta = -half*abs( aqoap-apoaq ) / aapq
1216 IF( aaqq.GT.aapp0 )theta = -theta
1217*
1218 IF( abs( theta ).GT.bigtheta ) THEN
1219 t = half / theta
1220 fastr( 3 ) = t*work( p ) / work( q )
1221 fastr( 4 ) = -t*work( q ) /
1222 $ work( p )
1223 CALL srotm( m, a( 1, p ), 1,
1224 $ a( 1, q ), 1, fastr )
1225 IF( rsvec )CALL srotm( mvl,
1226 $ v( 1, p ), 1,
1227 $ v( 1, q ), 1,
1228 $ fastr )
1229 sva( q ) = aaqq*sqrt( max( zero,
1230 $ one+t*apoaq*aapq ) )
1231 aapp = aapp*sqrt( max( zero,
1232 $ one-t*aqoap*aapq ) )
1233 mxsinj = max( mxsinj, abs( t ) )
1234 ELSE
1235*
1236* .. choose correct signum for THETA and rotate
1237*
1238 thsign = -sign( one, aapq )
1239 IF( aaqq.GT.aapp0 )thsign = -thsign
1240 t = one / ( theta+thsign*
1241 $ sqrt( one+theta*theta ) )
1242 cs = sqrt( one / ( one+t*t ) )
1243 sn = t*cs
1244 mxsinj = max( mxsinj, abs( sn ) )
1245 sva( q ) = aaqq*sqrt( max( zero,
1246 $ one+t*apoaq*aapq ) )
1247 aapp = aapp*sqrt( max( zero,
1248 $ one-t*aqoap*aapq ) )
1249*
1250 apoaq = work( p ) / work( q )
1251 aqoap = work( q ) / work( p )
1252 IF( work( p ).GE.one ) THEN
1253*
1254 IF( work( q ).GE.one ) THEN
1255 fastr( 3 ) = t*apoaq
1256 fastr( 4 ) = -t*aqoap
1257 work( p ) = work( p )*cs
1258 work( q ) = work( q )*cs
1259 CALL srotm( m, a( 1, p ), 1,
1260 $ a( 1, q ), 1,
1261 $ fastr )
1262 IF( rsvec )CALL srotm( mvl,
1263 $ v( 1, p ), 1, v( 1, q ),
1264 $ 1, fastr )
1265 ELSE
1266 CALL saxpy( m, -t*aqoap,
1267 $ a( 1, q ), 1,
1268 $ a( 1, p ), 1 )
1269 CALL saxpy( m, cs*sn*apoaq,
1270 $ a( 1, p ), 1,
1271 $ a( 1, q ), 1 )
1272 IF( rsvec ) THEN
1273 CALL saxpy( mvl, -t*aqoap,
1274 $ v( 1, q ), 1,
1275 $ v( 1, p ), 1 )
1276 CALL saxpy( mvl,
1277 $ cs*sn*apoaq,
1278 $ v( 1, p ), 1,
1279 $ v( 1, q ), 1 )
1280 END IF
1281 work( p ) = work( p )*cs
1282 work( q ) = work( q ) / cs
1283 END IF
1284 ELSE
1285 IF( work( q ).GE.one ) THEN
1286 CALL saxpy( m, t*apoaq,
1287 $ a( 1, p ), 1,
1288 $ a( 1, q ), 1 )
1289 CALL saxpy( m, -cs*sn*aqoap,
1290 $ a( 1, q ), 1,
1291 $ a( 1, p ), 1 )
1292 IF( rsvec ) THEN
1293 CALL saxpy( mvl, t*apoaq,
1294 $ v( 1, p ), 1,
1295 $ v( 1, q ), 1 )
1296 CALL saxpy( mvl,
1297 $ -cs*sn*aqoap,
1298 $ v( 1, q ), 1,
1299 $ v( 1, p ), 1 )
1300 END IF
1301 work( p ) = work( p ) / cs
1302 work( q ) = work( q )*cs
1303 ELSE
1304 IF( work( p ).GE.work( q ) )
1305 $ THEN
1306 CALL saxpy( m, -t*aqoap,
1307 $ a( 1, q ), 1,
1308 $ a( 1, p ), 1 )
1309 CALL saxpy( m, cs*sn*apoaq,
1310 $ a( 1, p ), 1,
1311 $ a( 1, q ), 1 )
1312 work( p ) = work( p )*cs
1313 work( q ) = work( q ) / cs
1314 IF( rsvec ) THEN
1315 CALL saxpy( mvl,
1316 $ -t*aqoap,
1317 $ v( 1, q ), 1,
1318 $ v( 1, p ), 1 )
1319 CALL saxpy( mvl,
1320 $ cs*sn*apoaq,
1321 $ v( 1, p ), 1,
1322 $ v( 1, q ), 1 )
1323 END IF
1324 ELSE
1325 CALL saxpy( m, t*apoaq,
1326 $ a( 1, p ), 1,
1327 $ a( 1, q ), 1 )
1328 CALL saxpy( m,
1329 $ -cs*sn*aqoap,
1330 $ a( 1, q ), 1,
1331 $ a( 1, p ), 1 )
1332 work( p ) = work( p ) / cs
1333 work( q ) = work( q )*cs
1334 IF( rsvec ) THEN
1335 CALL saxpy( mvl,
1336 $ t*apoaq, v( 1, p ),
1337 $ 1, v( 1, q ), 1 )
1338 CALL saxpy( mvl,
1339 $ -cs*sn*aqoap,
1340 $ v( 1, q ), 1,
1341 $ v( 1, p ), 1 )
1342 END IF
1343 END IF
1344 END IF
1345 END IF
1346 END IF
1347*
1348 ELSE
1349 IF( aapp.GT.aaqq ) THEN
1350 CALL scopy( m, a( 1, p ), 1,
1351 $ work( n+1 ), 1 )
1352 CALL slascl( 'G', 0, 0, aapp, one,
1353 $ m, 1, work( n+1 ), lda,
1354 $ ierr )
1355 CALL slascl( 'G', 0, 0, aaqq, one,
1356 $ m, 1, a( 1, q ), lda,
1357 $ ierr )
1358 temp1 = -aapq*work( p ) / work( q )
1359 CALL saxpy( m, temp1, work( n+1 ),
1360 $ 1, a( 1, q ), 1 )
1361 CALL slascl( 'G', 0, 0, one, aaqq,
1362 $ m, 1, a( 1, q ), lda,
1363 $ ierr )
1364 sva( q ) = aaqq*sqrt( max( zero,
1365 $ one-aapq*aapq ) )
1366 mxsinj = max( mxsinj, sfmin )
1367 ELSE
1368 CALL scopy( m, a( 1, q ), 1,
1369 $ work( n+1 ), 1 )
1370 CALL slascl( 'G', 0, 0, aaqq, one,
1371 $ m, 1, work( n+1 ), lda,
1372 $ ierr )
1373 CALL slascl( 'G', 0, 0, aapp, one,
1374 $ m, 1, a( 1, p ), lda,
1375 $ ierr )
1376 temp1 = -aapq*work( q ) / work( p )
1377 CALL saxpy( m, temp1, work( n+1 ),
1378 $ 1, a( 1, p ), 1 )
1379 CALL slascl( 'G', 0, 0, one, aapp,
1380 $ m, 1, a( 1, p ), lda,
1381 $ ierr )
1382 sva( p ) = aapp*sqrt( max( zero,
1383 $ one-aapq*aapq ) )
1384 mxsinj = max( mxsinj, sfmin )
1385 END IF
1386 END IF
1387* END IF ROTOK THEN ... ELSE
1388*
1389* In the case of cancellation in updating SVA(q)
1390* .. recompute SVA(q)
1391 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
1392 $ THEN
1393 IF( ( aaqq.LT.rootbig ) .AND.
1394 $ ( aaqq.GT.rootsfmin ) ) THEN
1395 sva( q ) = snrm2( m, a( 1, q ), 1 )*
1396 $ work( q )
1397 ELSE
1398 t = zero
1399 aaqq = one
1400 CALL slassq( m, a( 1, q ), 1, t,
1401 $ aaqq )
1402 sva( q ) = t*sqrt( aaqq )*work( q )
1403 END IF
1404 END IF
1405 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
1406 IF( ( aapp.LT.rootbig ) .AND.
1407 $ ( aapp.GT.rootsfmin ) ) THEN
1408 aapp = snrm2( m, a( 1, p ), 1 )*
1409 $ work( p )
1410 ELSE
1411 t = zero
1412 aapp = one
1413 CALL slassq( m, a( 1, p ), 1, t,
1414 $ aapp )
1415 aapp = t*sqrt( aapp )*work( p )
1416 END IF
1417 sva( p ) = aapp
1418 END IF
1419* end of OK rotation
1420 ELSE
1421 notrot = notrot + 1
1422*[RTD] SKIPPED = SKIPPED + 1
1423 pskipped = pskipped + 1
1424 ijblsk = ijblsk + 1
1425 END IF
1426 ELSE
1427 notrot = notrot + 1
1428 pskipped = pskipped + 1
1429 ijblsk = ijblsk + 1
1430 END IF
1431*
1432 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
1433 $ THEN
1434 sva( p ) = aapp
1435 notrot = 0
1436 GO TO 2011
1437 END IF
1438 IF( ( i.LE.swband ) .AND.
1439 $ ( pskipped.GT.rowskip ) ) THEN
1440 aapp = -aapp
1441 notrot = 0
1442 GO TO 2203
1443 END IF
1444*
1445 2200 CONTINUE
1446* end of the q-loop
1447 2203 CONTINUE
1448*
1449 sva( p ) = aapp
1450*
1451 ELSE
1452*
1453 IF( aapp.EQ.zero )notrot = notrot +
1454 $ min( jgl+kbl-1, n ) - jgl + 1
1455 IF( aapp.LT.zero )notrot = 0
1456*
1457 END IF
1458*
1459 2100 CONTINUE
1460* end of the p-loop
1461 2010 CONTINUE
1462* end of the jbc-loop
1463 2011 CONTINUE
1464*2011 bailed out of the jbc-loop
1465 DO 2012 p = igl, min( igl+kbl-1, n )
1466 sva( p ) = abs( sva( p ) )
1467 2012 CONTINUE
1468***
1469 2000 CONTINUE
1470*2000 :: end of the ibr-loop
1471*
1472* .. update SVA(N)
1473 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
1474 $ THEN
1475 sva( n ) = snrm2( m, a( 1, n ), 1 )*work( n )
1476 ELSE
1477 t = zero
1478 aapp = one
1479 CALL slassq( m, a( 1, n ), 1, t, aapp )
1480 sva( n ) = t*sqrt( aapp )*work( n )
1481 END IF
1482*
1483* Additional steering devices
1484*
1485 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
1486 $ ( iswrot.LE.n ) ) )swband = i
1487*
1488 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.sqrt( float( n ) )*
1489 $ tol ) .AND. ( float( n )*mxaapq*mxsinj.LT.tol ) ) THEN
1490 GO TO 1994
1491 END IF
1492*
1493 IF( notrot.GE.emptsw )GO TO 1994
1494*
1495 1993 CONTINUE
1496* end i=1:NSWEEP loop
1497*
1498* #:( Reaching this point means that the procedure has not converged.
1499 info = nsweep - 1
1500 GO TO 1995
1501*
1502 1994 CONTINUE
1503* #:) Reaching this point means numerical convergence after the i-th
1504* sweep.
1505*
1506 info = 0
1507* #:) INFO = 0 confirms successful iterations.
1508 1995 CONTINUE
1509*
1510* Sort the singular values and find how many are above
1511* the underflow threshold.
1512*
1513 n2 = 0
1514 n4 = 0
1515 DO 5991 p = 1, n - 1
1516 q = isamax( n-p+1, sva( p ), 1 ) + p - 1
1517 IF( p.NE.q ) THEN
1518 temp1 = sva( p )
1519 sva( p ) = sva( q )
1520 sva( q ) = temp1
1521 temp1 = work( p )
1522 work( p ) = work( q )
1523 work( q ) = temp1
1524 CALL sswap( m, a( 1, p ), 1, a( 1, q ), 1 )
1525 IF( rsvec )CALL sswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
1526 END IF
1527 IF( sva( p ).NE.zero ) THEN
1528 n4 = n4 + 1
1529 IF( sva( p )*skl.GT.sfmin )n2 = n2 + 1
1530 END IF
1531 5991 CONTINUE
1532 IF( sva( n ).NE.zero ) THEN
1533 n4 = n4 + 1
1534 IF( sva( n )*skl.GT.sfmin )n2 = n2 + 1
1535 END IF
1536*
1537* Normalize the left singular vectors.
1538*
1539 IF( lsvec .OR. uctol ) THEN
1540 DO 1998 p = 1, n2
1541 CALL sscal( m, work( p ) / sva( p ), a( 1, p ), 1 )
1542 1998 CONTINUE
1543 END IF
1544*
1545* Scale the product of Jacobi rotations (assemble the fast rotations).
1546*
1547 IF( rsvec ) THEN
1548 IF( applv ) THEN
1549 DO 2398 p = 1, n
1550 CALL sscal( mvl, work( p ), v( 1, p ), 1 )
1551 2398 CONTINUE
1552 ELSE
1553 DO 2399 p = 1, n
1554 temp1 = one / snrm2( mvl, v( 1, p ), 1 )
1555 CALL sscal( mvl, temp1, v( 1, p ), 1 )
1556 2399 CONTINUE
1557 END IF
1558 END IF
1559*
1560* Undo scaling, if necessary (and possible).
1561 IF( ( ( skl.GT.one ) .AND. ( sva( 1 ).LT.( big / skl ) ) )
1562 $ .OR. ( ( skl.LT.one ) .AND. ( sva( max( n2, 1 ) ) .GT.
1563 $ ( sfmin / skl ) ) ) ) THEN
1564 DO 2400 p = 1, n
1565 sva( p ) = skl*sva( p )
1566 2400 CONTINUE
1567 skl = one
1568 END IF
1569*
1570 work( 1 ) = skl
1571* The singular values of A are SKL*SVA(1:N). If SKL.NE.ONE
1572* then some of the singular values may overflow or underflow and
1573* the spectrum is given in this factored representation.
1574*
1575 work( 2 ) = float( n4 )
1576* N4 is the number of computed nonzero singular values of A.
1577*
1578 work( 3 ) = float( n2 )
1579* N2 is the number of singular values of A greater than SFMIN.
1580* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers
1581* that may carry some information.
1582*
1583 work( 4 ) = float( i )
1584* i is the index of the last sweep before declaring convergence.
1585*
1586 work( 5 ) = mxaapq
1587* MXAAPQ is the largest absolute value of scaled pivots in the
1588* last sweep
1589*
1590 work( 6 ) = mxsinj
1591* MXSINJ is the largest absolute value of the sines of Jacobi angles
1592* in the last sweep
1593*
1594 RETURN
1595* ..
1596* .. END OF SGESVJ
1597* ..
slassq
subroutine slassq(n, x, incx, scl, sumsq)
SLASSQ updates a sum of squares represented in scaled form.
Definition slassq.f90:137
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
slascl
subroutine slascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition slascl.f:143
sgsvj0
subroutine sgsvj0(jobv, m, n, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
SGSVJ0 pre-processor for the routine sgesvj.
Definition sgsvj0.f:218
sgsvj1
subroutine sgsvj1(jobv, m, n, n1, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
SGSVJ1 pre-processor for the routine sgesvj, applies Jacobi rotations targeting only particular pivot...
Definition sgsvj1.f:236
srotm
subroutine srotm(n, sx, incx, sy, incy, sparam)
SROTM
Definition srotm.f:97
sdot
real function sdot(n, sx, incx, sy, incy)
SDOT
Definition sdot.f:82

◆ sgetf2()

subroutine sgetf2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

SGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).

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

Purpose:
!>
!> SGETF2 computes an LU factorization of a general m-by-n matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the right-looking Level 2 BLAS version of the algorithm.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!>               has been completed, but the factor U 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.

Definition at line 107 of file sgetf2.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER INFO, LDA, M, N
115* ..
116* .. Array Arguments ..
117 INTEGER IPIV( * )
118 REAL A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 REAL ONE, ZERO
125 parameter( one = 1.0e+0, zero = 0.0e+0 )
126* ..
127* .. Local Scalars ..
128 REAL SFMIN
129 INTEGER I, J, JP
130* ..
131* .. External Functions ..
132 REAL SLAMCH
133 INTEGER ISAMAX
134 EXTERNAL slamch, isamax
135* ..
136* .. External Subroutines ..
137 EXTERNAL sger, sscal, sswap, xerbla
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC max, min
141* ..
142* .. Executable Statements ..
143*
144* Test the input parameters.
145*
146 info = 0
147 IF( m.LT.0 ) THEN
148 info = -1
149 ELSE IF( n.LT.0 ) THEN
150 info = -2
151 ELSE IF( lda.LT.max( 1, m ) ) THEN
152 info = -4
153 END IF
154 IF( info.NE.0 ) THEN
155 CALL xerbla( 'SGETF2', -info )
156 RETURN
157 END IF
158*
159* Quick return if possible
160*
161 IF( m.EQ.0 .OR. n.EQ.0 )
162 $ RETURN
163*
164* Compute machine safe minimum
165*
166 sfmin = slamch('S')
167*
168 DO 10 j = 1, min( m, n )
169*
170* Find pivot and test for singularity.
171*
172 jp = j - 1 + isamax( m-j+1, a( j, j ), 1 )
173 ipiv( j ) = jp
174 IF( a( jp, j ).NE.zero ) THEN
175*
176* Apply the interchange to columns 1:N.
177*
178 IF( jp.NE.j )
179 $ CALL sswap( n, a( j, 1 ), lda, a( jp, 1 ), lda )
180*
181* Compute elements J+1:M of J-th column.
182*
183 IF( j.LT.m ) THEN
184 IF( abs(a( j, j )) .GE. sfmin ) THEN
185 CALL sscal( m-j, one / a( j, j ), a( j+1, j ), 1 )
186 ELSE
187 DO 20 i = 1, m-j
188 a( j+i, j ) = a( j+i, j ) / a( j, j )
189 20 CONTINUE
190 END IF
191 END IF
192*
193 ELSE IF( info.EQ.0 ) THEN
194*
195 info = j
196 END IF
197*
198 IF( j.LT.min( m, n ) ) THEN
199*
200* Update trailing submatrix.
201*
202 CALL sger( m-j, n-j, -one, a( j+1, j ), 1, a( j, j+1 ), lda,
203 $ a( j+1, j+1 ), lda )
204 END IF
205 10 CONTINUE
206 RETURN
207*
208* End of SGETF2
209*

◆ sgetrf()

subroutine sgetrf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

SGETRF

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

Purpose:
!>
!> SGETRF computes an LU factorization of a general M-by-N matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the right-looking Level 3 BLAS version of the algorithm.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!>                has been completed, but the factor U 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.

Definition at line 107 of file sgetrf.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER INFO, LDA, M, N
115* ..
116* .. Array Arguments ..
117 INTEGER IPIV( * )
118 REAL A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 REAL ONE
125 parameter( one = 1.0e+0 )
126* ..
127* .. Local Scalars ..
128 INTEGER I, IINFO, J, JB, NB
129* ..
130* .. External Subroutines ..
131 EXTERNAL sgemm, sgetrf2, slaswp, strsm, xerbla
132* ..
133* .. External Functions ..
134 INTEGER ILAENV
135 EXTERNAL ilaenv
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC max, min
139* ..
140* .. Executable Statements ..
141*
142* Test the input parameters.
143*
144 info = 0
145 IF( m.LT.0 ) THEN
146 info = -1
147 ELSE IF( n.LT.0 ) THEN
148 info = -2
149 ELSE IF( lda.LT.max( 1, m ) ) THEN
150 info = -4
151 END IF
152 IF( info.NE.0 ) THEN
153 CALL xerbla( 'SGETRF', -info )
154 RETURN
155 END IF
156*
157* Quick return if possible
158*
159 IF( m.EQ.0 .OR. n.EQ.0 )
160 $ RETURN
161*
162* Determine the block size for this environment.
163*
164 nb = ilaenv( 1, 'SGETRF', ' ', m, n, -1, -1 )
165 IF( nb.LE.1 .OR. nb.GE.min( m, n ) ) THEN
166*
167* Use unblocked code.
168*
169 CALL sgetrf2( m, n, a, lda, ipiv, info )
170 ELSE
171*
172* Use blocked code.
173*
174 DO 20 j = 1, min( m, n ), nb
175 jb = min( min( m, n )-j+1, nb )
176*
177* Factor diagonal and subdiagonal blocks and test for exact
178* singularity.
179*
180 CALL sgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
181*
182* Adjust INFO and the pivot indices.
183*
184 IF( info.EQ.0 .AND. iinfo.GT.0 )
185 $ info = iinfo + j - 1
186 DO 10 i = j, min( m, j+jb-1 )
187 ipiv( i ) = j - 1 + ipiv( i )
188 10 CONTINUE
189*
190* Apply interchanges to columns 1:J-1.
191*
192 CALL slaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 )
193*
194 IF( j+jb.LE.n ) THEN
195*
196* Apply interchanges to columns J+JB:N.
197*
198 CALL slaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,
199 $ ipiv, 1 )
200*
201* Compute block row of U.
202*
203 CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', jb,
204 $ n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ),
205 $ lda )
206 IF( j+jb.LE.m ) THEN
207*
208* Update trailing submatrix.
209*
210 CALL sgemm( 'No transpose', 'No transpose', m-j-jb+1,
211 $ n-j-jb+1, jb, -one, a( j+jb, j ), lda,
212 $ a( j, j+jb ), lda, one, a( j+jb, j+jb ),
213 $ lda )
214 END IF
215 END IF
216 20 CONTINUE
217 END IF
218 RETURN
219*
220* End of SGETRF
221*
sgetrf2
recursive subroutine sgetrf2(m, n, a, lda, ipiv, info)
SGETRF2
Definition sgetrf2.f:113
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
strsm
subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRSM
Definition strsm.f:181

◆ sgetrf2()

recursive subroutine sgetrf2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

SGETRF2

Purpose:
!>
!> SGETRF2 computes an LU factorization of a general M-by-N matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the recursive version of the algorithm. It divides
!> the matrix into four submatrices:
!>
!>        [  A11 | A12  ]  where A11 is n1 by n1 and A22 is n2 by n2
!>    A = [ -----|----- ]  with n1 = min(m,n)/2
!>        [  A21 | A22  ]       n2 = n-n1
!>
!>                                       [ A11 ]
!> The subroutine calls itself to factor [ --- ],
!>                                       [ A12 ]
!>                 [ A12 ]
!> do the swaps on [ --- ], solve A12, update A22,
!>                 [ A22 ]
!>
!> then calls itself to factor A22 and do the swaps on A21.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!>                has been completed, but the factor U 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.

Definition at line 112 of file sgetrf2.f.

113*
114* -- LAPACK computational routine --
115* -- LAPACK is a software package provided by Univ. of Tennessee, --
116* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
117*
118* .. Scalar Arguments ..
119 INTEGER INFO, LDA, M, N
120* ..
121* .. Array Arguments ..
122 INTEGER IPIV( * )
123 REAL A( LDA, * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL ONE, ZERO
130 parameter( one = 1.0e+0, zero = 0.0e+0 )
131* ..
132* .. Local Scalars ..
133 REAL SFMIN, TEMP
134 INTEGER I, IINFO, n1, n2
135* ..
136* .. External Functions ..
137 REAL SLAMCH
138 INTEGER ISAMAX
139 EXTERNAL slamch, isamax
140* ..
141* .. External Subroutines ..
142 EXTERNAL sgemm, sscal, slaswp, strsm, xerbla
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max, min
146* ..
147* .. Executable Statements ..
148*
149* Test the input parameters
150*
151 info = 0
152 IF( m.LT.0 ) THEN
153 info = -1
154 ELSE IF( n.LT.0 ) THEN
155 info = -2
156 ELSE IF( lda.LT.max( 1, m ) ) THEN
157 info = -4
158 END IF
159 IF( info.NE.0 ) THEN
160 CALL xerbla( 'SGETRF2', -info )
161 RETURN
162 END IF
163*
164* Quick return if possible
165*
166 IF( m.EQ.0 .OR. n.EQ.0 )
167 $ RETURN
168
169 IF ( m.EQ.1 ) THEN
170*
171* Use unblocked code for one row case
172* Just need to handle IPIV and INFO
173*
174 ipiv( 1 ) = 1
175 IF ( a(1,1).EQ.zero )
176 $ info = 1
177*
178 ELSE IF( n.EQ.1 ) THEN
179*
180* Use unblocked code for one column case
181*
182*
183* Compute machine safe minimum
184*
185 sfmin = slamch('S')
186*
187* Find pivot and test for singularity
188*
189 i = isamax( m, a( 1, 1 ), 1 )
190 ipiv( 1 ) = i
191 IF( a( i, 1 ).NE.zero ) THEN
192*
193* Apply the interchange
194*
195 IF( i.NE.1 ) THEN
196 temp = a( 1, 1 )
197 a( 1, 1 ) = a( i, 1 )
198 a( i, 1 ) = temp
199 END IF
200*
201* Compute elements 2:M of the column
202*
203 IF( abs(a( 1, 1 )) .GE. sfmin ) THEN
204 CALL sscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 )
205 ELSE
206 DO 10 i = 1, m-1
207 a( 1+i, 1 ) = a( 1+i, 1 ) / a( 1, 1 )
208 10 CONTINUE
209 END IF
210*
211 ELSE
212 info = 1
213 END IF
214*
215 ELSE
216*
217* Use recursive code
218*
219 n1 = min( m, n ) / 2
220 n2 = n-n1
221*
222* [ A11 ]
223* Factor [ --- ]
224* [ A21 ]
225*
226 CALL sgetrf2( m, n1, a, lda, ipiv, iinfo )
227
228 IF ( info.EQ.0 .AND. iinfo.GT.0 )
229 $ info = iinfo
230*
231* [ A12 ]
232* Apply interchanges to [ --- ]
233* [ A22 ]
234*
235 CALL slaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 )
236*
237* Solve A12
238*
239 CALL strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,
240 $ a( 1, n1+1 ), lda )
241*
242* Update A22
243*
244 CALL sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,
245 $ a( 1, n1+1 ), lda, one, a( n1+1, n1+1 ), lda )
246*
247* Factor A22
248*
249 CALL sgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),
250 $ iinfo )
251*
252* Adjust INFO and the pivot indices
253*
254 IF ( info.EQ.0 .AND. iinfo.GT.0 )
255 $ info = iinfo + n1
256 DO 20 i = n1+1, min( m, n )
257 ipiv( i ) = ipiv( i ) + n1
258 20 CONTINUE
259*
260* Apply interchanges to A21
261*
262 CALL slaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 )
263*
264 END IF
265 RETURN
266*
267* End of SGETRF2
268*

◆ sgetri()

subroutine sgetri ( integer n,
real, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
real, dimension( * ) work,
integer lwork,
integer info )

SGETRI

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

Purpose:
!>
!> SGETRI computes the inverse of a matrix using the LU factorization
!> computed by SGETRF.
!>
!> This method inverts U and then computes inv(A) by solving the system
!> inv(A)*L = inv(U) for inv(A).
!>
Parameters
[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 factors L and U from the factorization
!>          A = P*L*U as computed by SGETRF.
!>          On exit, if INFO = 0, the inverse of the original matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from SGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>          For optimal performance LWORK >= N*NB, where NB is
!>          the optimal blocksize 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, U(i,i) is exactly zero; 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 sgetri.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 INTEGER INFO, LDA, LWORK, N
121* ..
122* .. Array Arguments ..
123 INTEGER IPIV( * )
124 REAL A( LDA, * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 REAL ZERO, ONE
131 parameter( zero = 0.0e+0, one = 1.0e+0 )
132* ..
133* .. Local Scalars ..
134 LOGICAL LQUERY
135 INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
136 $ NBMIN, NN
137* ..
138* .. External Functions ..
139 INTEGER ILAENV
140 EXTERNAL ilaenv
141* ..
142* .. External Subroutines ..
143 EXTERNAL sgemm, sgemv, sswap, strsm, strtri, xerbla
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC max, min
147* ..
148* .. Executable Statements ..
149*
150* Test the input parameters.
151*
152 info = 0
153 nb = ilaenv( 1, 'SGETRI', ' ', n, -1, -1, -1 )
154 lwkopt = n*nb
155 work( 1 ) = lwkopt
156 lquery = ( lwork.EQ.-1 )
157 IF( n.LT.0 ) THEN
158 info = -1
159 ELSE IF( lda.LT.max( 1, n ) ) THEN
160 info = -3
161 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
162 info = -6
163 END IF
164 IF( info.NE.0 ) THEN
165 CALL xerbla( 'SGETRI', -info )
166 RETURN
167 ELSE IF( lquery ) THEN
168 RETURN
169 END IF
170*
171* Quick return if possible
172*
173 IF( n.EQ.0 )
174 $ RETURN
175*
176* Form inv(U). If INFO > 0 from STRTRI, then U is singular,
177* and the inverse is not computed.
178*
179 CALL strtri( 'Upper', 'Non-unit', n, a, lda, info )
180 IF( info.GT.0 )
181 $ RETURN
182*
183 nbmin = 2
184 ldwork = n
185 IF( nb.GT.1 .AND. nb.LT.n ) THEN
186 iws = max( ldwork*nb, 1 )
187 IF( lwork.LT.iws ) THEN
188 nb = lwork / ldwork
189 nbmin = max( 2, ilaenv( 2, 'SGETRI', ' ', n, -1, -1, -1 ) )
190 END IF
191 ELSE
192 iws = n
193 END IF
194*
195* Solve the equation inv(A)*L = inv(U) for inv(A).
196*
197 IF( nb.LT.nbmin .OR. nb.GE.n ) THEN
198*
199* Use unblocked code.
200*
201 DO 20 j = n, 1, -1
202*
203* Copy current column of L to WORK and replace with zeros.
204*
205 DO 10 i = j + 1, n
206 work( i ) = a( i, j )
207 a( i, j ) = zero
208 10 CONTINUE
209*
210* Compute current column of inv(A).
211*
212 IF( j.LT.n )
213 $ CALL sgemv( 'No transpose', n, n-j, -one, a( 1, j+1 ),
214 $ lda, work( j+1 ), 1, one, a( 1, j ), 1 )
215 20 CONTINUE
216 ELSE
217*
218* Use blocked code.
219*
220 nn = ( ( n-1 ) / nb )*nb + 1
221 DO 50 j = nn, 1, -nb
222 jb = min( nb, n-j+1 )
223*
224* Copy current block column of L to WORK and replace with
225* zeros.
226*
227 DO 40 jj = j, j + jb - 1
228 DO 30 i = jj + 1, n
229 work( i+( jj-j )*ldwork ) = a( i, jj )
230 a( i, jj ) = zero
231 30 CONTINUE
232 40 CONTINUE
233*
234* Compute current block column of inv(A).
235*
236 IF( j+jb.LE.n )
237 $ CALL sgemm( 'No transpose', 'No transpose', n, jb,
238 $ n-j-jb+1, -one, a( 1, j+jb ), lda,
239 $ work( j+jb ), ldwork, one, a( 1, j ), lda )
240 CALL strsm( 'Right', 'Lower', 'No transpose', 'Unit', n, jb,
241 $ one, work( j ), ldwork, a( 1, j ), lda )
242 50 CONTINUE
243 END IF
244*
245* Apply column interchanges.
246*
247 DO 60 j = n - 1, 1, -1
248 jp = ipiv( j )
249 IF( jp.NE.j )
250 $ CALL sswap( n, a( 1, j ), 1, a( 1, jp ), 1 )
251 60 CONTINUE
252*
253 work( 1 ) = iws
254 RETURN
255*
256* End of SGETRI
257*
strtri
subroutine strtri(uplo, diag, n, a, lda, info)
STRTRI
Definition strtri.f:109

◆ sgetrs()

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

SGETRS

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

Purpose:
!>
!> SGETRS solves a system of linear equations
!>    A * X = B  or  A**T * X = B
!> with a general N-by-N matrix A using the LU factorization computed
!> by SGETRF.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B  (No transpose)
!>          = 'T':  A**T* X = B  (Transpose)
!>          = 'C':  A**T* X = B  (Conjugate transpose = Transpose)
!>
[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 factors L and U from the factorization A = P*L*U
!>          as computed by SGETRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from SGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[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 120 of file sgetrs.f.

121*
122* -- LAPACK computational routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 CHARACTER TRANS
128 INTEGER INFO, LDA, LDB, N, NRHS
129* ..
130* .. Array Arguments ..
131 INTEGER IPIV( * )
132 REAL A( LDA, * ), B( LDB, * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 REAL ONE
139 parameter( one = 1.0e+0 )
140* ..
141* .. Local Scalars ..
142 LOGICAL NOTRAN
143* ..
144* .. External Functions ..
145 LOGICAL LSAME
146 EXTERNAL lsame
147* ..
148* .. External Subroutines ..
149 EXTERNAL slaswp, strsm, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC max
153* ..
154* .. Executable Statements ..
155*
156* Test the input parameters.
157*
158 info = 0
159 notran = lsame( trans, 'N' )
160 IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
161 $ lsame( trans, 'C' ) ) THEN
162 info = -1
163 ELSE IF( n.LT.0 ) THEN
164 info = -2
165 ELSE IF( nrhs.LT.0 ) THEN
166 info = -3
167 ELSE IF( lda.LT.max( 1, n ) ) THEN
168 info = -5
169 ELSE IF( ldb.LT.max( 1, n ) ) THEN
170 info = -8
171 END IF
172 IF( info.NE.0 ) THEN
173 CALL xerbla( 'SGETRS', -info )
174 RETURN
175 END IF
176*
177* Quick return if possible
178*
179 IF( n.EQ.0 .OR. nrhs.EQ.0 )
180 $ RETURN
181*
182 IF( notran ) THEN
183*
184* Solve A * X = B.
185*
186* Apply row interchanges to the right hand sides.
187*
188 CALL slaswp( nrhs, b, ldb, 1, n, ipiv, 1 )
189*
190* Solve L*X = B, overwriting B with X.
191*
192 CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', n, nrhs,
193 $ one, a, lda, b, ldb )
194*
195* Solve U*X = B, overwriting B with X.
196*
197 CALL strsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n,
198 $ nrhs, one, a, lda, b, ldb )
199 ELSE
200*
201* Solve A**T * X = B.
202*
203* Solve U**T *X = B, overwriting B with X.
204*
205 CALL strsm( 'Left', 'Upper', 'Transpose', 'Non-unit', n, nrhs,
206 $ one, a, lda, b, ldb )
207*
208* Solve L**T *X = B, overwriting B with X.
209*
210 CALL strsm( 'Left', 'Lower', 'Transpose', 'Unit', n, nrhs, one,
211 $ a, lda, b, ldb )
212*
213* Apply row interchanges to the solution vectors.
214*
215 CALL slaswp( nrhs, b, ldb, 1, n, ipiv, -1 )
216 END IF
217*
218 RETURN
219*
220* End of SGETRS
221*

◆ shgeqz()

subroutine shgeqz ( character job,
character compq,
character compz,
integer n,
integer ilo,
integer ihi,
real, dimension( ldh, * ) h,
integer ldh,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( * ) alphar,
real, dimension( * ) alphai,
real, dimension( * ) beta,
real, dimension( ldq, * ) q,
integer ldq,
real, dimension( ldz, * ) z,
integer ldz,
real, dimension( * ) work,
integer lwork,
integer info )

SHGEQZ

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

Purpose:
!>
!> SHGEQZ computes the eigenvalues of a real matrix pair (H,T),
!> where H is an upper Hessenberg matrix and T is upper triangular,
!> using the double-shift QZ method.
!> Matrix pairs of this type are produced by the reduction to
!> generalized upper Hessenberg form of a real matrix pair (A,B):
!>
!>    A = Q1*H*Z1**T,  B = Q1*T*Z1**T,
!>
!> as computed by SGGHRD.
!>
!> If JOB='S', then the Hessenberg-triangular pair (H,T) is
!> also reduced to generalized Schur form,
!>
!>    H = Q*S*Z**T,  T = Q*P*Z**T,
!>
!> where Q and Z are orthogonal matrices, P is an upper triangular
!> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
!> diagonal blocks.
!>
!> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
!> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
!> eigenvalues.
!>
!> Additionally, the 2-by-2 upper triangular diagonal blocks of P
!> corresponding to 2-by-2 blocks of S are reduced to positive diagonal
!> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
!> P(j,j) > 0, and P(j+1,j+1) > 0.
!>
!> Optionally, the orthogonal matrix Q from the generalized Schur
!> factorization may be postmultiplied into an input matrix Q1, and the
!> orthogonal matrix Z may be postmultiplied into an input matrix Z1.
!> If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
!> the matrix pair (A,B) to generalized upper Hessenberg form, then the
!> output matrices Q1*Q and Z1*Z are the orthogonal factors from the
!> generalized Schur factorization of (A,B):
!>
!>    A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.
!>
!> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
!> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
!> complex and beta real.
!> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
!> generalized nonsymmetric eigenvalue problem (GNEP)
!>    A*x = lambda*B*x
!> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
!> alternate form of the GNEP
!>    mu*A*y = B*y.
!> Real eigenvalues can be read directly from the generalized Schur
!> form:
!>   alpha = S(i,i), beta = P(i,i).
!>
!> Ref: C.B. Moler & G.W. Stewart, , SIAM J. Numer. Anal., 10(1973),
!>      pp. 241--256.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          = 'E': Compute eigenvalues only;
!>          = 'S': Compute eigenvalues and the Schur form.
!>
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'N': Left Schur vectors (Q) are not computed;
!>          = 'I': Q is initialized to the unit matrix and the matrix Q
!>                 of left Schur vectors of (H,T) is returned;
!>          = 'V': Q must contain an orthogonal matrix Q1 on entry and
!>                 the product Q1*Q is returned.
!>
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N': Right Schur vectors (Z) are not computed;
!>          = 'I': Z is initialized to the unit matrix and the matrix Z
!>                 of right Schur vectors of (H,T) is returned;
!>          = 'V': Z must contain an orthogonal matrix Z1 on entry and
!>                 the product Z1*Z is returned.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices H, T, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          ILO and IHI mark the rows and columns of H which are in
!>          Hessenberg form.  It is assumed that A is already upper
!>          triangular in rows and columns 1:ILO-1 and IHI+1:N.
!>          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
!>
[in,out]H
!>          H is REAL array, dimension (LDH, N)
!>          On entry, the N-by-N upper Hessenberg matrix H.
!>          On exit, if JOB = 'S', H contains the upper quasi-triangular
!>          matrix S from the generalized Schur factorization.
!>          If JOB = 'E', the diagonal blocks of H match those of S, but
!>          the rest of H is unspecified.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H.  LDH >= max( 1, N ).
!>
[in,out]T
!>          T is REAL array, dimension (LDT, N)
!>          On entry, the N-by-N upper triangular matrix T.
!>          On exit, if JOB = 'S', T contains the upper triangular
!>          matrix P from the generalized Schur factorization;
!>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
!>          are reduced to positive diagonal form, i.e., if H(j+1,j) is
!>          non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
!>          T(j+1,j+1) > 0.
!>          If JOB = 'E', the diagonal blocks of T match those of P, but
!>          the rest of T is unspecified.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= max( 1, N ).
!>
[out]ALPHAR
!>          ALPHAR is REAL array, dimension (N)
!>          The real parts of each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]ALPHAI
!>          ALPHAI is REAL array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.
!>          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
!>          positive, then the j-th and (j+1)-st eigenvalues are a
!>          complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
!>
[out]BETA
!>          BETA is REAL array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPQ = 'I', the orthogonal matrix of left Schur
!>          vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix
!>          of left Schur vectors of (A,B).
!>          Not referenced if COMPQ = 'N'.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= 1.
!>          If COMPQ='V' or 'I', then LDQ >= N.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPZ = 'I', the orthogonal matrix of
!>          right Schur vectors of (H,T), and if COMPZ = 'V', the
!>          orthogonal matrix of right Schur vectors of (A,B).
!>          Not referenced if COMPZ = 'N'.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1.
!>          If COMPZ='V' or 'I', then LDZ >= N.
!>
[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 >= max(1,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]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1,...,N: the QZ iteration did not converge.  (H,T) is not
!>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!>                     BETA(i), i=INFO+1,...,N should be correct.
!>          = N+1,...,2*N: the shift calculation failed.  (H,T) is not
!>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!>                     BETA(i), i=INFO-N+1,...,N should be correct.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Iteration counters:
!>
!>  JITER  -- counts iterations.
!>  IITER  -- counts iterations run since ILAST was last
!>            changed.  This is therefore reset only when a 1-by-1 or
!>            2-by-2 block deflates off the bottom.
!>

Definition at line 301 of file shgeqz.f.

304*
305* -- LAPACK computational routine --
306* -- LAPACK is a software package provided by Univ. of Tennessee, --
307* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
308*
309* .. Scalar Arguments ..
310 CHARACTER COMPQ, COMPZ, JOB
311 INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
312* ..
313* .. Array Arguments ..
314 REAL ALPHAI( * ), ALPHAR( * ), BETA( * ),
315 $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
316 $ WORK( * ), Z( LDZ, * )
317* ..
318*
319* =====================================================================
320*
321* .. Parameters ..
322* $ SAFETY = 1.0E+0 )
323 REAL HALF, ZERO, ONE, SAFETY
324 parameter( half = 0.5e+0, zero = 0.0e+0, one = 1.0e+0,
325 $ safety = 1.0e+2 )
326* ..
327* .. Local Scalars ..
328 LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
329 $ LQUERY
330 INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
331 $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
332 $ JR, MAXIT
333 REAL A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
334 $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
335 $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
336 $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
337 $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
338 $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
339 $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
340 $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
341 $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
342 $ WR2
343* ..
344* .. Local Arrays ..
345 REAL V( 3 )
346* ..
347* .. External Functions ..
348 LOGICAL LSAME
349 REAL SLAMCH, SLANHS, SLAPY2, SLAPY3
350 EXTERNAL lsame, slamch, slanhs, slapy2, slapy3
351* ..
352* .. External Subroutines ..
353 EXTERNAL slag2, slarfg, slartg, slaset, slasv2, srot,
354 $ xerbla
355* ..
356* .. Intrinsic Functions ..
357 INTRINSIC abs, max, min, real, sqrt
358* ..
359* .. Executable Statements ..
360*
361* Decode JOB, COMPQ, COMPZ
362*
363 IF( lsame( job, 'E' ) ) THEN
364 ilschr = .false.
365 ischur = 1
366 ELSE IF( lsame( job, 'S' ) ) THEN
367 ilschr = .true.
368 ischur = 2
369 ELSE
370 ischur = 0
371 END IF
372*
373 IF( lsame( compq, 'N' ) ) THEN
374 ilq = .false.
375 icompq = 1
376 ELSE IF( lsame( compq, 'V' ) ) THEN
377 ilq = .true.
378 icompq = 2
379 ELSE IF( lsame( compq, 'I' ) ) THEN
380 ilq = .true.
381 icompq = 3
382 ELSE
383 icompq = 0
384 END IF
385*
386 IF( lsame( compz, 'N' ) ) THEN
387 ilz = .false.
388 icompz = 1
389 ELSE IF( lsame( compz, 'V' ) ) THEN
390 ilz = .true.
391 icompz = 2
392 ELSE IF( lsame( compz, 'I' ) ) THEN
393 ilz = .true.
394 icompz = 3
395 ELSE
396 icompz = 0
397 END IF
398*
399* Check Argument Values
400*
401 info = 0
402 work( 1 ) = max( 1, n )
403 lquery = ( lwork.EQ.-1 )
404 IF( ischur.EQ.0 ) THEN
405 info = -1
406 ELSE IF( icompq.EQ.0 ) THEN
407 info = -2
408 ELSE IF( icompz.EQ.0 ) THEN
409 info = -3
410 ELSE IF( n.LT.0 ) THEN
411 info = -4
412 ELSE IF( ilo.LT.1 ) THEN
413 info = -5
414 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
415 info = -6
416 ELSE IF( ldh.LT.n ) THEN
417 info = -8
418 ELSE IF( ldt.LT.n ) THEN
419 info = -10
420 ELSE IF( ldq.LT.1 .OR. ( ilq .AND. ldq.LT.n ) ) THEN
421 info = -15
422 ELSE IF( ldz.LT.1 .OR. ( ilz .AND. ldz.LT.n ) ) THEN
423 info = -17
424 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
425 info = -19
426 END IF
427 IF( info.NE.0 ) THEN
428 CALL xerbla( 'SHGEQZ', -info )
429 RETURN
430 ELSE IF( lquery ) THEN
431 RETURN
432 END IF
433*
434* Quick return if possible
435*
436 IF( n.LE.0 ) THEN
437 work( 1 ) = real( 1 )
438 RETURN
439 END IF
440*
441* Initialize Q and Z
442*
443 IF( icompq.EQ.3 )
444 $ CALL slaset( 'Full', n, n, zero, one, q, ldq )
445 IF( icompz.EQ.3 )
446 $ CALL slaset( 'Full', n, n, zero, one, z, ldz )
447*
448* Machine Constants
449*
450 in = ihi + 1 - ilo
451 safmin = slamch( 'S' )
452 safmax = one / safmin
453 ulp = slamch( 'E' )*slamch( 'B' )
454 anorm = slanhs( 'F', in, h( ilo, ilo ), ldh, work )
455 bnorm = slanhs( 'F', in, t( ilo, ilo ), ldt, work )
456 atol = max( safmin, ulp*anorm )
457 btol = max( safmin, ulp*bnorm )
458 ascale = one / max( safmin, anorm )
459 bscale = one / max( safmin, bnorm )
460*
461* Set Eigenvalues IHI+1:N
462*
463 DO 30 j = ihi + 1, n
464 IF( t( j, j ).LT.zero ) THEN
465 IF( ilschr ) THEN
466 DO 10 jr = 1, j
467 h( jr, j ) = -h( jr, j )
468 t( jr, j ) = -t( jr, j )
469 10 CONTINUE
470 ELSE
471 h( j, j ) = -h( j, j )
472 t( j, j ) = -t( j, j )
473 END IF
474 IF( ilz ) THEN
475 DO 20 jr = 1, n
476 z( jr, j ) = -z( jr, j )
477 20 CONTINUE
478 END IF
479 END IF
480 alphar( j ) = h( j, j )
481 alphai( j ) = zero
482 beta( j ) = t( j, j )
483 30 CONTINUE
484*
485* If IHI < ILO, skip QZ steps
486*
487 IF( ihi.LT.ilo )
488 $ GO TO 380
489*
490* MAIN QZ ITERATION LOOP
491*
492* Initialize dynamic indices
493*
494* Eigenvalues ILAST+1:N have been found.
495* Column operations modify rows IFRSTM:whatever.
496* Row operations modify columns whatever:ILASTM.
497*
498* If only eigenvalues are being computed, then
499* IFRSTM is the row of the last splitting row above row ILAST;
500* this is always at least ILO.
501* IITER counts iterations since the last eigenvalue was found,
502* to tell when to use an extraordinary shift.
503* MAXIT is the maximum number of QZ sweeps allowed.
504*
505 ilast = ihi
506 IF( ilschr ) THEN
507 ifrstm = 1
508 ilastm = n
509 ELSE
510 ifrstm = ilo
511 ilastm = ihi
512 END IF
513 iiter = 0
514 eshift = zero
515 maxit = 30*( ihi-ilo+1 )
516*
517 DO 360 jiter = 1, maxit
518*
519* Split the matrix if possible.
520*
521* Two tests:
522* 1: H(j,j-1)=0 or j=ILO
523* 2: T(j,j)=0
524*
525 IF( ilast.EQ.ilo ) THEN
526*
527* Special case: j=ILAST
528*
529 GO TO 80
530 ELSE
531 IF( abs( h( ilast, ilast-1 ) ).LE.max( safmin, ulp*(
532 $ abs( h( ilast, ilast ) ) + abs( h( ilast-1, ilast-1 ) )
533 $ ) ) ) THEN
534 h( ilast, ilast-1 ) = zero
535 GO TO 80
536 END IF
537 END IF
538*
539 IF( abs( t( ilast, ilast ) ).LE.max( safmin, ulp*(
540 $ abs( t( ilast - 1, ilast ) ) + abs( t( ilast-1, ilast-1 )
541 $ ) ) ) ) THEN
542 t( ilast, ilast ) = zero
543 GO TO 70
544 END IF
545*
546* General case: j<ILAST
547*
548 DO 60 j = ilast - 1, ilo, -1
549*
550* Test 1: for H(j,j-1)=0 or j=ILO
551*
552 IF( j.EQ.ilo ) THEN
553 ilazro = .true.
554 ELSE
555 IF( abs( h( j, j-1 ) ).LE.max( safmin, ulp*(
556 $ abs( h( j, j ) ) + abs( h( j-1, j-1 ) )
557 $ ) ) ) THEN
558 h( j, j-1 ) = zero
559 ilazro = .true.
560 ELSE
561 ilazro = .false.
562 END IF
563 END IF
564*
565* Test 2: for T(j,j)=0
566*
567 temp = abs( t( j, j + 1 ) )
568 IF ( j .GT. ilo )
569 $ temp = temp + abs( t( j - 1, j ) )
570 IF( abs( t( j, j ) ).LT.max( safmin,ulp*temp ) ) THEN
571 t( j, j ) = zero
572*
573* Test 1a: Check for 2 consecutive small subdiagonals in A
574*
575 ilazr2 = .false.
576 IF( .NOT.ilazro ) THEN
577 temp = abs( h( j, j-1 ) )
578 temp2 = abs( h( j, j ) )
579 tempr = max( temp, temp2 )
580 IF( tempr.LT.one .AND. tempr.NE.zero ) THEN
581 temp = temp / tempr
582 temp2 = temp2 / tempr
583 END IF
584 IF( temp*( ascale*abs( h( j+1, j ) ) ).LE.temp2*
585 $ ( ascale*atol ) )ilazr2 = .true.
586 END IF
587*
588* If both tests pass (1 & 2), i.e., the leading diagonal
589* element of B in the block is zero, split a 1x1 block off
590* at the top. (I.e., at the J-th row/column) The leading
591* diagonal element of the remainder can also be zero, so
592* this may have to be done repeatedly.
593*
594 IF( ilazro .OR. ilazr2 ) THEN
595 DO 40 jch = j, ilast - 1
596 temp = h( jch, jch )
597 CALL slartg( temp, h( jch+1, jch ), c, s,
598 $ h( jch, jch ) )
599 h( jch+1, jch ) = zero
600 CALL srot( ilastm-jch, h( jch, jch+1 ), ldh,
601 $ h( jch+1, jch+1 ), ldh, c, s )
602 CALL srot( ilastm-jch, t( jch, jch+1 ), ldt,
603 $ t( jch+1, jch+1 ), ldt, c, s )
604 IF( ilq )
605 $ CALL srot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,
606 $ c, s )
607 IF( ilazr2 )
608 $ h( jch, jch-1 ) = h( jch, jch-1 )*c
609 ilazr2 = .false.
610 IF( abs( t( jch+1, jch+1 ) ).GE.btol ) THEN
611 IF( jch+1.GE.ilast ) THEN
612 GO TO 80
613 ELSE
614 ifirst = jch + 1
615 GO TO 110
616 END IF
617 END IF
618 t( jch+1, jch+1 ) = zero
619 40 CONTINUE
620 GO TO 70
621 ELSE
622*
623* Only test 2 passed -- chase the zero to T(ILAST,ILAST)
624* Then process as in the case T(ILAST,ILAST)=0
625*
626 DO 50 jch = j, ilast - 1
627 temp = t( jch, jch+1 )
628 CALL slartg( temp, t( jch+1, jch+1 ), c, s,
629 $ t( jch, jch+1 ) )
630 t( jch+1, jch+1 ) = zero
631 IF( jch.LT.ilastm-1 )
632 $ CALL srot( ilastm-jch-1, t( jch, jch+2 ), ldt,
633 $ t( jch+1, jch+2 ), ldt, c, s )
634 CALL srot( ilastm-jch+2, h( jch, jch-1 ), ldh,
635 $ h( jch+1, jch-1 ), ldh, c, s )
636 IF( ilq )
637 $ CALL srot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,
638 $ c, s )
639 temp = h( jch+1, jch )
640 CALL slartg( temp, h( jch+1, jch-1 ), c, s,
641 $ h( jch+1, jch ) )
642 h( jch+1, jch-1 ) = zero
643 CALL srot( jch+1-ifrstm, h( ifrstm, jch ), 1,
644 $ h( ifrstm, jch-1 ), 1, c, s )
645 CALL srot( jch-ifrstm, t( ifrstm, jch ), 1,
646 $ t( ifrstm, jch-1 ), 1, c, s )
647 IF( ilz )
648 $ CALL srot( n, z( 1, jch ), 1, z( 1, jch-1 ), 1,
649 $ c, s )
650 50 CONTINUE
651 GO TO 70
652 END IF
653 ELSE IF( ilazro ) THEN
654*
655* Only test 1 passed -- work on J:ILAST
656*
657 ifirst = j
658 GO TO 110
659 END IF
660*
661* Neither test passed -- try next J
662*
663 60 CONTINUE
664*
665* (Drop-through is "impossible")
666*
667 info = n + 1
668 GO TO 420
669*
670* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
671* 1x1 block.
672*
673 70 CONTINUE
674 temp = h( ilast, ilast )
675 CALL slartg( temp, h( ilast, ilast-1 ), c, s,
676 $ h( ilast, ilast ) )
677 h( ilast, ilast-1 ) = zero
678 CALL srot( ilast-ifrstm, h( ifrstm, ilast ), 1,
679 $ h( ifrstm, ilast-1 ), 1, c, s )
680 CALL srot( ilast-ifrstm, t( ifrstm, ilast ), 1,
681 $ t( ifrstm, ilast-1 ), 1, c, s )
682 IF( ilz )
683 $ CALL srot( n, z( 1, ilast ), 1, z( 1, ilast-1 ), 1, c, s )
684*
685* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
686* and BETA
687*
688 80 CONTINUE
689 IF( t( ilast, ilast ).LT.zero ) THEN
690 IF( ilschr ) THEN
691 DO 90 j = ifrstm, ilast
692 h( j, ilast ) = -h( j, ilast )
693 t( j, ilast ) = -t( j, ilast )
694 90 CONTINUE
695 ELSE
696 h( ilast, ilast ) = -h( ilast, ilast )
697 t( ilast, ilast ) = -t( ilast, ilast )
698 END IF
699 IF( ilz ) THEN
700 DO 100 j = 1, n
701 z( j, ilast ) = -z( j, ilast )
702 100 CONTINUE
703 END IF
704 END IF
705 alphar( ilast ) = h( ilast, ilast )
706 alphai( ilast ) = zero
707 beta( ilast ) = t( ilast, ilast )
708*
709* Go to next block -- exit if finished.
710*
711 ilast = ilast - 1
712 IF( ilast.LT.ilo )
713 $ GO TO 380
714*
715* Reset counters
716*
717 iiter = 0
718 eshift = zero
719 IF( .NOT.ilschr ) THEN
720 ilastm = ilast
721 IF( ifrstm.GT.ilast )
722 $ ifrstm = ilo
723 END IF
724 GO TO 350
725*
726* QZ step
727*
728* This iteration only involves rows/columns IFIRST:ILAST. We
729* assume IFIRST < ILAST, and that the diagonal of B is non-zero.
730*
731 110 CONTINUE
732 iiter = iiter + 1
733 IF( .NOT.ilschr ) THEN
734 ifrstm = ifirst
735 END IF
736*
737* Compute single shifts.
738*
739* At this point, IFIRST < ILAST, and the diagonal elements of
740* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
741* magnitude)
742*
743 IF( ( iiter / 10 )*10.EQ.iiter ) THEN
744*
745* Exceptional shift. Chosen for no particularly good reason.
746* (Single shift only.)
747*
748 IF( ( real( maxit )*safmin )*abs( h( ilast, ilast-1 ) ).LT.
749 $ abs( t( ilast-1, ilast-1 ) ) ) THEN
750 eshift = h( ilast, ilast-1 ) /
751 $ t( ilast-1, ilast-1 )
752 ELSE
753 eshift = eshift + one / ( safmin*real( maxit ) )
754 END IF
755 s1 = one
756 wr = eshift
757*
758 ELSE
759*
760* Shifts based on the generalized eigenvalues of the
761* bottom-right 2x2 block of A and B. The first eigenvalue
762* returned by SLAG2 is the Wilkinson shift (AEP p.512),
763*
764 CALL slag2( h( ilast-1, ilast-1 ), ldh,
765 $ t( ilast-1, ilast-1 ), ldt, safmin*safety, s1,
766 $ s2, wr, wr2, wi )
767*
768 IF ( abs( (wr/s1)*t( ilast, ilast ) - h( ilast, ilast ) )
769 $ .GT. abs( (wr2/s2)*t( ilast, ilast )
770 $ - h( ilast, ilast ) ) ) THEN
771 temp = wr
772 wr = wr2
773 wr2 = temp
774 temp = s1
775 s1 = s2
776 s2 = temp
777 END IF
778 temp = max( s1, safmin*max( one, abs( wr ), abs( wi ) ) )
779 IF( wi.NE.zero )
780 $ GO TO 200
781 END IF
782*
783* Fiddle with shift to avoid overflow
784*
785 temp = min( ascale, one )*( half*safmax )
786 IF( s1.GT.temp ) THEN
787 scale = temp / s1
788 ELSE
789 scale = one
790 END IF
791*
792 temp = min( bscale, one )*( half*safmax )
793 IF( abs( wr ).GT.temp )
794 $ scale = min( scale, temp / abs( wr ) )
795 s1 = scale*s1
796 wr = scale*wr
797*
798* Now check for two consecutive small subdiagonals.
799*
800 DO 120 j = ilast - 1, ifirst + 1, -1
801 istart = j
802 temp = abs( s1*h( j, j-1 ) )
803 temp2 = abs( s1*h( j, j )-wr*t( j, j ) )
804 tempr = max( temp, temp2 )
805 IF( tempr.LT.one .AND. tempr.NE.zero ) THEN
806 temp = temp / tempr
807 temp2 = temp2 / tempr
808 END IF
809 IF( abs( ( ascale*h( j+1, j ) )*temp ).LE.( ascale*atol )*
810 $ temp2 )GO TO 130
811 120 CONTINUE
812*
813 istart = ifirst
814 130 CONTINUE
815*
816* Do an implicit single-shift QZ sweep.
817*
818* Initial Q
819*
820 temp = s1*h( istart, istart ) - wr*t( istart, istart )
821 temp2 = s1*h( istart+1, istart )
822 CALL slartg( temp, temp2, c, s, tempr )
823*
824* Sweep
825*
826 DO 190 j = istart, ilast - 1
827 IF( j.GT.istart ) THEN
828 temp = h( j, j-1 )
829 CALL slartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) )
830 h( j+1, j-1 ) = zero
831 END IF
832*
833 DO 140 jc = j, ilastm
834 temp = c*h( j, jc ) + s*h( j+1, jc )
835 h( j+1, jc ) = -s*h( j, jc ) + c*h( j+1, jc )
836 h( j, jc ) = temp
837 temp2 = c*t( j, jc ) + s*t( j+1, jc )
838 t( j+1, jc ) = -s*t( j, jc ) + c*t( j+1, jc )
839 t( j, jc ) = temp2
840 140 CONTINUE
841 IF( ilq ) THEN
842 DO 150 jr = 1, n
843 temp = c*q( jr, j ) + s*q( jr, j+1 )
844 q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 )
845 q( jr, j ) = temp
846 150 CONTINUE
847 END IF
848*
849 temp = t( j+1, j+1 )
850 CALL slartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) )
851 t( j+1, j ) = zero
852*
853 DO 160 jr = ifrstm, min( j+2, ilast )
854 temp = c*h( jr, j+1 ) + s*h( jr, j )
855 h( jr, j ) = -s*h( jr, j+1 ) + c*h( jr, j )
856 h( jr, j+1 ) = temp
857 160 CONTINUE
858 DO 170 jr = ifrstm, j
859 temp = c*t( jr, j+1 ) + s*t( jr, j )
860 t( jr, j ) = -s*t( jr, j+1 ) + c*t( jr, j )
861 t( jr, j+1 ) = temp
862 170 CONTINUE
863 IF( ilz ) THEN
864 DO 180 jr = 1, n
865 temp = c*z( jr, j+1 ) + s*z( jr, j )
866 z( jr, j ) = -s*z( jr, j+1 ) + c*z( jr, j )
867 z( jr, j+1 ) = temp
868 180 CONTINUE
869 END IF
870 190 CONTINUE
871*
872 GO TO 350
873*
874* Use Francis double-shift
875*
876* Note: the Francis double-shift should work with real shifts,
877* but only if the block is at least 3x3.
878* This code may break if this point is reached with
879* a 2x2 block with real eigenvalues.
880*
881 200 CONTINUE
882 IF( ifirst+1.EQ.ilast ) THEN
883*
884* Special case -- 2x2 block with complex eigenvectors
885*
886* Step 1: Standardize, that is, rotate so that
887*
888* ( B11 0 )
889* B = ( ) with B11 non-negative.
890* ( 0 B22 )
891*
892 CALL slasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),
893 $ t( ilast, ilast ), b22, b11, sr, cr, sl, cl )
894*
895 IF( b11.LT.zero ) THEN
896 cr = -cr
897 sr = -sr
898 b11 = -b11
899 b22 = -b22
900 END IF
901*
902 CALL srot( ilastm+1-ifirst, h( ilast-1, ilast-1 ), ldh,
903 $ h( ilast, ilast-1 ), ldh, cl, sl )
904 CALL srot( ilast+1-ifrstm, h( ifrstm, ilast-1 ), 1,
905 $ h( ifrstm, ilast ), 1, cr, sr )
906*
907 IF( ilast.LT.ilastm )
908 $ CALL srot( ilastm-ilast, t( ilast-1, ilast+1 ), ldt,
909 $ t( ilast, ilast+1 ), ldt, cl, sl )
910 IF( ifrstm.LT.ilast-1 )
911 $ CALL srot( ifirst-ifrstm, t( ifrstm, ilast-1 ), 1,
912 $ t( ifrstm, ilast ), 1, cr, sr )
913*
914 IF( ilq )
915 $ CALL srot( n, q( 1, ilast-1 ), 1, q( 1, ilast ), 1, cl,
916 $ sl )
917 IF( ilz )
918 $ CALL srot( n, z( 1, ilast-1 ), 1, z( 1, ilast ), 1, cr,
919 $ sr )
920*
921 t( ilast-1, ilast-1 ) = b11
922 t( ilast-1, ilast ) = zero
923 t( ilast, ilast-1 ) = zero
924 t( ilast, ilast ) = b22
925*
926* If B22 is negative, negate column ILAST
927*
928 IF( b22.LT.zero ) THEN
929 DO 210 j = ifrstm, ilast
930 h( j, ilast ) = -h( j, ilast )
931 t( j, ilast ) = -t( j, ilast )
932 210 CONTINUE
933*
934 IF( ilz ) THEN
935 DO 220 j = 1, n
936 z( j, ilast ) = -z( j, ilast )
937 220 CONTINUE
938 END IF
939 b22 = -b22
940 END IF
941*
942* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
943*
944* Recompute shift
945*
946 CALL slag2( h( ilast-1, ilast-1 ), ldh,
947 $ t( ilast-1, ilast-1 ), ldt, safmin*safety, s1,
948 $ temp, wr, temp2, wi )
949*
950* If standardization has perturbed the shift onto real line,
951* do another (real single-shift) QR step.
952*
953 IF( wi.EQ.zero )
954 $ GO TO 350
955 s1inv = one / s1
956*
957* Do EISPACK (QZVAL) computation of alpha and beta
958*
959 a11 = h( ilast-1, ilast-1 )
960 a21 = h( ilast, ilast-1 )
961 a12 = h( ilast-1, ilast )
962 a22 = h( ilast, ilast )
963*
964* Compute complex Givens rotation on right
965* (Assume some element of C = (sA - wB) > unfl )
966* __
967* (sA - wB) ( CZ -SZ )
968* ( SZ CZ )
969*
970 c11r = s1*a11 - wr*b11
971 c11i = -wi*b11
972 c12 = s1*a12
973 c21 = s1*a21
974 c22r = s1*a22 - wr*b22
975 c22i = -wi*b22
976*
977 IF( abs( c11r )+abs( c11i )+abs( c12 ).GT.abs( c21 )+
978 $ abs( c22r )+abs( c22i ) ) THEN
979 t1 = slapy3( c12, c11r, c11i )
980 cz = c12 / t1
981 szr = -c11r / t1
982 szi = -c11i / t1
983 ELSE
984 cz = slapy2( c22r, c22i )
985 IF( cz.LE.safmin ) THEN
986 cz = zero
987 szr = one
988 szi = zero
989 ELSE
990 tempr = c22r / cz
991 tempi = c22i / cz
992 t1 = slapy2( cz, c21 )
993 cz = cz / t1
994 szr = -c21*tempr / t1
995 szi = c21*tempi / t1
996 END IF
997 END IF
998*
999* Compute Givens rotation on left
1000*
1001* ( CQ SQ )
1002* ( __ ) A or B
1003* ( -SQ CQ )
1004*
1005 an = abs( a11 ) + abs( a12 ) + abs( a21 ) + abs( a22 )
1006 bn = abs( b11 ) + abs( b22 )
1007 wabs = abs( wr ) + abs( wi )
1008 IF( s1*an.GT.wabs*bn ) THEN
1009 cq = cz*b11
1010 sqr = szr*b22
1011 sqi = -szi*b22
1012 ELSE
1013 a1r = cz*a11 + szr*a12
1014 a1i = szi*a12
1015 a2r = cz*a21 + szr*a22
1016 a2i = szi*a22
1017 cq = slapy2( a1r, a1i )
1018 IF( cq.LE.safmin ) THEN
1019 cq = zero
1020 sqr = one
1021 sqi = zero
1022 ELSE
1023 tempr = a1r / cq
1024 tempi = a1i / cq
1025 sqr = tempr*a2r + tempi*a2i
1026 sqi = tempi*a2r - tempr*a2i
1027 END IF
1028 END IF
1029 t1 = slapy3( cq, sqr, sqi )
1030 cq = cq / t1
1031 sqr = sqr / t1
1032 sqi = sqi / t1
1033*
1034* Compute diagonal elements of QBZ
1035*
1036 tempr = sqr*szr - sqi*szi
1037 tempi = sqr*szi + sqi*szr
1038 b1r = cq*cz*b11 + tempr*b22
1039 b1i = tempi*b22
1040 b1a = slapy2( b1r, b1i )
1041 b2r = cq*cz*b22 + tempr*b11
1042 b2i = -tempi*b11
1043 b2a = slapy2( b2r, b2i )
1044*
1045* Normalize so beta > 0, and Im( alpha1 ) > 0
1046*
1047 beta( ilast-1 ) = b1a
1048 beta( ilast ) = b2a
1049 alphar( ilast-1 ) = ( wr*b1a )*s1inv
1050 alphai( ilast-1 ) = ( wi*b1a )*s1inv
1051 alphar( ilast ) = ( wr*b2a )*s1inv
1052 alphai( ilast ) = -( wi*b2a )*s1inv
1053*
1054* Step 3: Go to next block -- exit if finished.
1055*
1056 ilast = ifirst - 1
1057 IF( ilast.LT.ilo )
1058 $ GO TO 380
1059*
1060* Reset counters
1061*
1062 iiter = 0
1063 eshift = zero
1064 IF( .NOT.ilschr ) THEN
1065 ilastm = ilast
1066 IF( ifrstm.GT.ilast )
1067 $ ifrstm = ilo
1068 END IF
1069 GO TO 350
1070 ELSE
1071*
1072* Usual case: 3x3 or larger block, using Francis implicit
1073* double-shift
1074*
1075* 2
1076* Eigenvalue equation is w - c w + d = 0,
1077*
1078* -1 2 -1
1079* so compute 1st column of (A B ) - c A B + d
1080* using the formula in QZIT (from EISPACK)
1081*
1082* We assume that the block is at least 3x3
1083*
1084 ad11 = ( ascale*h( ilast-1, ilast-1 ) ) /
1085 $ ( bscale*t( ilast-1, ilast-1 ) )
1086 ad21 = ( ascale*h( ilast, ilast-1 ) ) /
1087 $ ( bscale*t( ilast-1, ilast-1 ) )
1088 ad12 = ( ascale*h( ilast-1, ilast ) ) /
1089 $ ( bscale*t( ilast, ilast ) )
1090 ad22 = ( ascale*h( ilast, ilast ) ) /
1091 $ ( bscale*t( ilast, ilast ) )
1092 u12 = t( ilast-1, ilast ) / t( ilast, ilast )
1093 ad11l = ( ascale*h( ifirst, ifirst ) ) /
1094 $ ( bscale*t( ifirst, ifirst ) )
1095 ad21l = ( ascale*h( ifirst+1, ifirst ) ) /
1096 $ ( bscale*t( ifirst, ifirst ) )
1097 ad12l = ( ascale*h( ifirst, ifirst+1 ) ) /
1098 $ ( bscale*t( ifirst+1, ifirst+1 ) )
1099 ad22l = ( ascale*h( ifirst+1, ifirst+1 ) ) /
1100 $ ( bscale*t( ifirst+1, ifirst+1 ) )
1101 ad32l = ( ascale*h( ifirst+2, ifirst+1 ) ) /
1102 $ ( bscale*t( ifirst+1, ifirst+1 ) )
1103 u12l = t( ifirst, ifirst+1 ) / t( ifirst+1, ifirst+1 )
1104*
1105 v( 1 ) = ( ad11-ad11l )*( ad22-ad11l ) - ad12*ad21 +
1106 $ ad21*u12*ad11l + ( ad12l-ad11l*u12l )*ad21l
1107 v( 2 ) = ( ( ad22l-ad11l )-ad21l*u12l-( ad11-ad11l )-
1108 $ ( ad22-ad11l )+ad21*u12 )*ad21l
1109 v( 3 ) = ad32l*ad21l
1110*
1111 istart = ifirst
1112*
1113 CALL slarfg( 3, v( 1 ), v( 2 ), 1, tau )
1114 v( 1 ) = one
1115*
1116* Sweep
1117*
1118 DO 290 j = istart, ilast - 2
1119*
1120* All but last elements: use 3x3 Householder transforms.
1121*
1122* Zero (j-1)st column of A
1123*
1124 IF( j.GT.istart ) THEN
1125 v( 1 ) = h( j, j-1 )
1126 v( 2 ) = h( j+1, j-1 )
1127 v( 3 ) = h( j+2, j-1 )
1128*
1129 CALL slarfg( 3, h( j, j-1 ), v( 2 ), 1, tau )
1130 v( 1 ) = one
1131 h( j+1, j-1 ) = zero
1132 h( j+2, j-1 ) = zero
1133 END IF
1134*
1135 DO 230 jc = j, ilastm
1136 temp = tau*( h( j, jc )+v( 2 )*h( j+1, jc )+v( 3 )*
1137 $ h( j+2, jc ) )
1138 h( j, jc ) = h( j, jc ) - temp
1139 h( j+1, jc ) = h( j+1, jc ) - temp*v( 2 )
1140 h( j+2, jc ) = h( j+2, jc ) - temp*v( 3 )
1141 temp2 = tau*( t( j, jc )+v( 2 )*t( j+1, jc )+v( 3 )*
1142 $ t( j+2, jc ) )
1143 t( j, jc ) = t( j, jc ) - temp2
1144 t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2 )
1145 t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3 )
1146 230 CONTINUE
1147 IF( ilq ) THEN
1148 DO 240 jr = 1, n
1149 temp = tau*( q( jr, j )+v( 2 )*q( jr, j+1 )+v( 3 )*
1150 $ q( jr, j+2 ) )
1151 q( jr, j ) = q( jr, j ) - temp
1152 q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2 )
1153 q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3 )
1154 240 CONTINUE
1155 END IF
1156*
1157* Zero j-th column of B (see SLAGBC for details)
1158*
1159* Swap rows to pivot
1160*
1161 ilpivt = .false.
1162 temp = max( abs( t( j+1, j+1 ) ), abs( t( j+1, j+2 ) ) )
1163 temp2 = max( abs( t( j+2, j+1 ) ), abs( t( j+2, j+2 ) ) )
1164 IF( max( temp, temp2 ).LT.safmin ) THEN
1165 scale = zero
1166 u1 = one
1167 u2 = zero
1168 GO TO 250
1169 ELSE IF( temp.GE.temp2 ) THEN
1170 w11 = t( j+1, j+1 )
1171 w21 = t( j+2, j+1 )
1172 w12 = t( j+1, j+2 )
1173 w22 = t( j+2, j+2 )
1174 u1 = t( j+1, j )
1175 u2 = t( j+2, j )
1176 ELSE
1177 w21 = t( j+1, j+1 )
1178 w11 = t( j+2, j+1 )
1179 w22 = t( j+1, j+2 )
1180 w12 = t( j+2, j+2 )
1181 u2 = t( j+1, j )
1182 u1 = t( j+2, j )
1183 END IF
1184*
1185* Swap columns if nec.
1186*
1187 IF( abs( w12 ).GT.abs( w11 ) ) THEN
1188 ilpivt = .true.
1189 temp = w12
1190 temp2 = w22
1191 w12 = w11
1192 w22 = w21
1193 w11 = temp
1194 w21 = temp2
1195 END IF
1196*
1197* LU-factor
1198*
1199 temp = w21 / w11
1200 u2 = u2 - temp*u1
1201 w22 = w22 - temp*w12
1202 w21 = zero
1203*
1204* Compute SCALE
1205*
1206 scale = one
1207 IF( abs( w22 ).LT.safmin ) THEN
1208 scale = zero
1209 u2 = one
1210 u1 = -w12 / w11
1211 GO TO 250
1212 END IF
1213 IF( abs( w22 ).LT.abs( u2 ) )
1214 $ scale = abs( w22 / u2 )
1215 IF( abs( w11 ).LT.abs( u1 ) )
1216 $ scale = min( scale, abs( w11 / u1 ) )
1217*
1218* Solve
1219*
1220 u2 = ( scale*u2 ) / w22
1221 u1 = ( scale*u1-w12*u2 ) / w11
1222*
1223 250 CONTINUE
1224 IF( ilpivt ) THEN
1225 temp = u2
1226 u2 = u1
1227 u1 = temp
1228 END IF
1229*
1230* Compute Householder Vector
1231*
1232 t1 = sqrt( scale**2+u1**2+u2**2 )
1233 tau = one + scale / t1
1234 vs = -one / ( scale+t1 )
1235 v( 1 ) = one
1236 v( 2 ) = vs*u1
1237 v( 3 ) = vs*u2
1238*
1239* Apply transformations from the right.
1240*
1241 DO 260 jr = ifrstm, min( j+3, ilast )
1242 temp = tau*( h( jr, j )+v( 2 )*h( jr, j+1 )+v( 3 )*
1243 $ h( jr, j+2 ) )
1244 h( jr, j ) = h( jr, j ) - temp
1245 h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2 )
1246 h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3 )
1247 260 CONTINUE
1248 DO 270 jr = ifrstm, j + 2
1249 temp = tau*( t( jr, j )+v( 2 )*t( jr, j+1 )+v( 3 )*
1250 $ t( jr, j+2 ) )
1251 t( jr, j ) = t( jr, j ) - temp
1252 t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2 )
1253 t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3 )
1254 270 CONTINUE
1255 IF( ilz ) THEN
1256 DO 280 jr = 1, n
1257 temp = tau*( z( jr, j )+v( 2 )*z( jr, j+1 )+v( 3 )*
1258 $ z( jr, j+2 ) )
1259 z( jr, j ) = z( jr, j ) - temp
1260 z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2 )
1261 z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3 )
1262 280 CONTINUE
1263 END IF
1264 t( j+1, j ) = zero
1265 t( j+2, j ) = zero
1266 290 CONTINUE
1267*
1268* Last elements: Use Givens rotations
1269*
1270* Rotations from the left
1271*
1272 j = ilast - 1
1273 temp = h( j, j-1 )
1274 CALL slartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) )
1275 h( j+1, j-1 ) = zero
1276*
1277 DO 300 jc = j, ilastm
1278 temp = c*h( j, jc ) + s*h( j+1, jc )
1279 h( j+1, jc ) = -s*h( j, jc ) + c*h( j+1, jc )
1280 h( j, jc ) = temp
1281 temp2 = c*t( j, jc ) + s*t( j+1, jc )
1282 t( j+1, jc ) = -s*t( j, jc ) + c*t( j+1, jc )
1283 t( j, jc ) = temp2
1284 300 CONTINUE
1285 IF( ilq ) THEN
1286 DO 310 jr = 1, n
1287 temp = c*q( jr, j ) + s*q( jr, j+1 )
1288 q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 )
1289 q( jr, j ) = temp
1290 310 CONTINUE
1291 END IF
1292*
1293* Rotations from the right.
1294*
1295 temp = t( j+1, j+1 )
1296 CALL slartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) )
1297 t( j+1, j ) = zero
1298*
1299 DO 320 jr = ifrstm, ilast
1300 temp = c*h( jr, j+1 ) + s*h( jr, j )
1301 h( jr, j ) = -s*h( jr, j+1 ) + c*h( jr, j )
1302 h( jr, j+1 ) = temp
1303 320 CONTINUE
1304 DO 330 jr = ifrstm, ilast - 1
1305 temp = c*t( jr, j+1 ) + s*t( jr, j )
1306 t( jr, j ) = -s*t( jr, j+1 ) + c*t( jr, j )
1307 t( jr, j+1 ) = temp
1308 330 CONTINUE
1309 IF( ilz ) THEN
1310 DO 340 jr = 1, n
1311 temp = c*z( jr, j+1 ) + s*z( jr, j )
1312 z( jr, j ) = -s*z( jr, j+1 ) + c*z( jr, j )
1313 z( jr, j+1 ) = temp
1314 340 CONTINUE
1315 END IF
1316*
1317* End of Double-Shift code
1318*
1319 END IF
1320*
1321 GO TO 350
1322*
1323* End of iteration loop
1324*
1325 350 CONTINUE
1326 360 CONTINUE
1327*
1328* Drop-through = non-convergence
1329*
1330 info = ilast
1331 GO TO 420
1332*
1333* Successful completion of all QZ steps
1334*
1335 380 CONTINUE
1336*
1337* Set Eigenvalues 1:ILO-1
1338*
1339 DO 410 j = 1, ilo - 1
1340 IF( t( j, j ).LT.zero ) THEN
1341 IF( ilschr ) THEN
1342 DO 390 jr = 1, j
1343 h( jr, j ) = -h( jr, j )
1344 t( jr, j ) = -t( jr, j )
1345 390 CONTINUE
1346 ELSE
1347 h( j, j ) = -h( j, j )
1348 t( j, j ) = -t( j, j )
1349 END IF
1350 IF( ilz ) THEN
1351 DO 400 jr = 1, n
1352 z( jr, j ) = -z( jr, j )
1353 400 CONTINUE
1354 END IF
1355 END IF
1356 alphar( j ) = h( j, j )
1357 alphai( j ) = zero
1358 beta( j ) = t( j, j )
1359 410 CONTINUE
1360*
1361* Normal Termination
1362*
1363 info = 0
1364*
1365* Exit (other than argument error) -- return optimal workspace size
1366*
1367 420 CONTINUE
1368 work( 1 ) = real( n )
1369 RETURN
1370*
1371* End of SHGEQZ
1372*
slasv2
subroutine slasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition slasv2.f:138
slapy2
real function slapy2(x, y)
SLAPY2 returns sqrt(x2+y2).
Definition slapy2.f:63
slartg
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition slartg.f90:113
slapy3
real function slapy3(x, y, z)
SLAPY3 returns sqrt(x2+y2+z2).
Definition slapy3.f:68
slanhs
real function slanhs(norm, n, a, lda, work)
SLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slanhs.f:108
slag2
subroutine slag2(a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi)
SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
Definition slag2.f:156
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
SROT
Definition srot.f:92
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ sla_geamv()

subroutine sla_geamv ( integer trans,
integer m,
integer n,
real alpha,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) x,
integer incx,
real beta,
real, dimension( * ) y,
integer incy )

SLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.

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

Purpose:
!>
!> SLA_GEAMV  performs one of the matrix-vector operations
!>
!>         y := alpha*abs(A)*abs(x) + beta*abs(y),
!>    or   y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> m by n 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]TRANS
!>          TRANS is INTEGER
!>           On entry, TRANS specifies the operation to be performed as
!>           follows:
!>
!>             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)
!>             BLAS_TRANS         y := alpha*abs(A**T)*abs(x) + beta*abs(y)
!>             BLAS_CONJ_TRANS    y := alpha*abs(A**T)*abs(x) + beta*abs(y)
!>
!>           Unchanged on exit.
!>
[in]M
!>          M is INTEGER
!>           On entry, M specifies the number of rows of the matrix A.
!>           M must be at least zero.
!>           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, m ).
!>           Unchanged on exit.
!>
[in]X
!>          X is REAL array, dimension
!>           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!>           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 at least
!>           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!>           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.
!>
!>  Level 2 Blas routine.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file sla_geamv.f.

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

◆ sla_gercond()

real function sla_gercond ( character trans,
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_GERCOND estimates the Skeel condition number for a general matrix.

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

Purpose:
!>
!>    SLA_GERCOND 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]TRANS
!>          TRANS is CHARACTER*1
!>     Specifies the form of the system of equations:
!>       = 'N':  A * X = B     (No transpose)
!>       = 'T':  A**T * X = B  (Transpose)
!>       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)
!>
[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 factors L and U from the factorization
!>     A = P*L*U as computed by SGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from the factorization A = P*L*U
!>     as computed by SGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[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.2
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 148 of file sla_gercond.f.

150*
151* -- LAPACK computational routine --
152* -- LAPACK is a software package provided by Univ. of Tennessee, --
153* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
154*
155* .. Scalar Arguments ..
156 CHARACTER TRANS
157 INTEGER N, LDA, LDAF, INFO, CMODE
158* ..
159* .. Array Arguments ..
160 INTEGER IPIV( * ), IWORK( * )
161 REAL A( LDA, * ), AF( LDAF, * ), WORK( * ),
162 $ C( * )
163* ..
164*
165* =====================================================================
166*
167* .. Local Scalars ..
168 LOGICAL NOTRANS
169 INTEGER KASE, I, J
170 REAL AINVNM, TMP
171* ..
172* .. Local Arrays ..
173 INTEGER ISAVE( 3 )
174* ..
175* .. External Functions ..
176 LOGICAL LSAME
177 EXTERNAL lsame
178* ..
179* .. External Subroutines ..
180 EXTERNAL slacn2, sgetrs, xerbla
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC abs, max
184* ..
185* .. Executable Statements ..
186*
187 sla_gercond = 0.0
188*
189 info = 0
190 notrans = lsame( trans, 'N' )
191 IF ( .NOT. notrans .AND. .NOT. lsame(trans, 'T')
192 $ .AND. .NOT. lsame(trans, 'C') ) THEN
193 info = -1
194 ELSE IF( n.LT.0 ) THEN
195 info = -2
196 ELSE IF( lda.LT.max( 1, n ) ) THEN
197 info = -4
198 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
199 info = -6
200 END IF
201 IF( info.NE.0 ) THEN
202 CALL xerbla( 'SLA_GERCOND', -info )
203 RETURN
204 END IF
205 IF( n.EQ.0 ) THEN
206 sla_gercond = 1.0
207 RETURN
208 END IF
209*
210* Compute the equilibration matrix R such that
211* inv(R)*A*C has unit 1-norm.
212*
213 IF (notrans) THEN
214 DO i = 1, n
215 tmp = 0.0
216 IF ( cmode .EQ. 1 ) THEN
217 DO j = 1, n
218 tmp = tmp + abs( a( i, j ) * c( j ) )
219 END DO
220 ELSE IF ( cmode .EQ. 0 ) THEN
221 DO j = 1, n
222 tmp = tmp + abs( a( i, j ) )
223 END DO
224 ELSE
225 DO j = 1, n
226 tmp = tmp + abs( a( i, j ) / c( j ) )
227 END DO
228 END IF
229 work( 2*n+i ) = tmp
230 END DO
231 ELSE
232 DO i = 1, n
233 tmp = 0.0
234 IF ( cmode .EQ. 1 ) THEN
235 DO j = 1, n
236 tmp = tmp + abs( a( j, i ) * c( j ) )
237 END DO
238 ELSE IF ( cmode .EQ. 0 ) THEN
239 DO j = 1, n
240 tmp = tmp + abs( a( j, i ) )
241 END DO
242 ELSE
243 DO j = 1, n
244 tmp = tmp + abs( a( j, i ) / c( j ) )
245 END DO
246 END IF
247 work( 2*n+i ) = tmp
248 END DO
249 END IF
250*
251* Estimate the norm of inv(op(A)).
252*
253 ainvnm = 0.0
254
255 kase = 0
256 10 CONTINUE
257 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
258 IF( kase.NE.0 ) THEN
259 IF( kase.EQ.2 ) THEN
260*
261* Multiply by R.
262*
263 DO i = 1, n
264 work(i) = work(i) * work(2*n+i)
265 END DO
266
267 IF (notrans) THEN
268 CALL sgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
269 $ work, n, info )
270 ELSE
271 CALL sgetrs( 'Transpose', n, 1, af, ldaf, ipiv,
272 $ work, n, info )
273 END IF
274*
275* Multiply by inv(C).
276*
277 IF ( cmode .EQ. 1 ) THEN
278 DO i = 1, n
279 work( i ) = work( i ) / c( i )
280 END DO
281 ELSE IF ( cmode .EQ. -1 ) THEN
282 DO i = 1, n
283 work( i ) = work( i ) * c( i )
284 END DO
285 END IF
286 ELSE
287*
288* Multiply by inv(C**T).
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
300 IF (notrans) THEN
301 CALL sgetrs( 'Transpose', n, 1, af, ldaf, ipiv,
302 $ work, n, info )
303 ELSE
304 CALL sgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
305 $ work, n, info )
306 END IF
307*
308* Multiply by R.
309*
310 DO i = 1, n
311 work( i ) = work( i ) * work( 2*n+i )
312 END DO
313 END IF
314 GO TO 10
315 END IF
316*
317* Compute the estimate of the reciprocal condition number.
318*
319 IF( ainvnm .NE. 0.0 )
320 $ sla_gercond = ( 1.0 / ainvnm )
321*
322 RETURN
323*
324* End of SLA_GERCOND
325*

◆ sla_gerfsx_extended()

subroutine sla_gerfsx_extended ( integer prec_type,
integer trans_type,
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, * ) errs_n,
real, dimension( nrhs, * ) errs_c,
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_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.

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

Purpose:
!>
!> SLA_GERFSX_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 SGERFSX to perform iterative refinement.
!> In addition to normwise error bound, the code provides maximum
!> componentwise error bound if possible. See comments for ERRS_N
!> and ERRS_C for details of the error bounds. Note that this
!> subroutine is only responsible for setting the second fields of
!> ERRS_N and ERRS_C.
!>
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]TRANS_TYPE
!>          TRANS_TYPE is INTEGER
!>     Specifies the transposition operation on A.
!>     The value is defined by ILATRANS(T) where T is a CHARACTER and T
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose
!>
[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 factors L and U from the factorization
!>     A = P*L*U as computed by SGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from the factorization A = P*L*U
!>     as computed by SGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[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 SGETRS.
!>     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 ERRS_N
!>     and ERRS_C).
!>     If N_NORMS >= 1 return normwise error bounds.
!>     If N_NORMS >= 2 return componentwise error bounds.
!>
[in,out]ERRS_N
!>          ERRS_N 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 ERRS_N(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERRS_N(:,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]ERRS_C
!>          ERRS_C 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
!>     ERRS_C is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERRS_C(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERRS_C(:,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
!>     ERRS_N and ERRS_C 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 SGETRS had an illegal
!>             value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 391 of file sla_gerfsx_extended.f.

398*
399* -- LAPACK computational routine --
400* -- LAPACK is a software package provided by Univ. of Tennessee, --
401* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
402*
403* .. Scalar Arguments ..
404 INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE,
405 $ TRANS_TYPE, N_NORMS, ITHRESH
406 LOGICAL COLEQU, IGNORE_CWISE
407 REAL RTHRESH, DZ_UB
408* ..
409* .. Array Arguments ..
410 INTEGER IPIV( * )
411 REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
412 $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * )
413 REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
414 $ ERRS_N( NRHS, * ),
415 $ ERRS_C( NRHS, * )
416* ..
417*
418* =====================================================================
419*
420* .. Local Scalars ..
421 CHARACTER TRANS
422 INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE
423 REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
424 $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,
425 $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,
426 $ EPS, HUGEVAL, INCR_THRESH
427 LOGICAL INCR_PREC
428* ..
429* .. Parameters ..
430 INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE,
431 $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL,
432 $ EXTRA_Y
433 parameter( unstable_state = 0, working_state = 1,
434 $ conv_state = 2, noprog_state = 3 )
435 parameter( base_residual = 0, extra_residual = 1,
436 $ extra_y = 2 )
437 INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I
438 INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I
439 INTEGER CMP_ERR_I, PIV_GROWTH_I
440 parameter( final_nrm_err_i = 1, final_cmp_err_i = 2,
441 $ berr_i = 3 )
442 parameter( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
443 parameter( cmp_rcond_i = 7, cmp_err_i = 8,
444 $ piv_growth_i = 9 )
445 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
446 $ LA_LINRX_CWISE_I
447 parameter( la_linrx_itref_i = 1,
448 $ la_linrx_ithresh_i = 2 )
449 parameter( la_linrx_cwise_i = 3 )
450 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
451 $ LA_LINRX_RCOND_I
452 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
453 parameter( la_linrx_rcond_i = 3 )
454* ..
455* .. External Subroutines ..
456 EXTERNAL saxpy, scopy, sgetrs, sgemv, blas_sgemv_x,
457 $ blas_sgemv2_x, sla_geamv, sla_wwaddw, slamch,
458 $ chla_transtype, sla_lin_berr
459 REAL SLAMCH
460 CHARACTER CHLA_TRANSTYPE
461* ..
462* .. Intrinsic Functions ..
463 INTRINSIC abs, max, min
464* ..
465* .. Executable Statements ..
466*
467 IF ( info.NE.0 ) RETURN
468 trans = chla_transtype(trans_type)
469 eps = slamch( 'Epsilon' )
470 hugeval = slamch( 'Overflow' )
471* Force HUGEVAL to Inf
472 hugeval = hugeval * hugeval
473* Using HUGEVAL may lead to spurious underflows.
474 incr_thresh = real( n ) * eps
475*
476 DO j = 1, nrhs
477 y_prec_state = extra_residual
478 IF ( y_prec_state .EQ. extra_y ) THEN
479 DO i = 1, n
480 y_tail( i ) = 0.0
481 END DO
482 END IF
483
484 dxrat = 0.0
485 dxratmax = 0.0
486 dzrat = 0.0
487 dzratmax = 0.0
488 final_dx_x = hugeval
489 final_dz_z = hugeval
490 prevnormdx = hugeval
491 prev_dz_z = hugeval
492 dz_z = hugeval
493 dx_x = hugeval
494
495 x_state = working_state
496 z_state = unstable_state
497 incr_prec = .false.
498
499 DO cnt = 1, ithresh
500*
501* Compute residual RES = B_s - op(A_s) * Y,
502* op(A) = A, A**T, or A**H depending on TRANS (and type).
503*
504 CALL scopy( n, b( 1, j ), 1, res, 1 )
505 IF ( y_prec_state .EQ. base_residual ) THEN
506 CALL sgemv( trans, n, n, -1.0, a, lda, y( 1, j ), 1,
507 $ 1.0, res, 1 )
508 ELSE IF ( y_prec_state .EQ. extra_residual ) THEN
509 CALL blas_sgemv_x( trans_type, n, n, -1.0, a, lda,
510 $ y( 1, j ), 1, 1.0, res, 1, prec_type )
511 ELSE
512 CALL blas_sgemv2_x( trans_type, n, n, -1.0, a, lda,
513 $ y( 1, j ), y_tail, 1, 1.0, res, 1, prec_type )
514 END IF
515
516! XXX: RES is no longer needed.
517 CALL scopy( n, res, 1, dy, 1 )
518 CALL sgetrs( trans, n, 1, af, ldaf, ipiv, dy, n, info )
519*
520* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT.
521*
522 normx = 0.0
523 normy = 0.0
524 normdx = 0.0
525 dz_z = 0.0
526 ymin = hugeval
527*
528 DO i = 1, n
529 yk = abs( y( i, j ) )
530 dyk = abs( dy( i ) )
531
532 IF ( yk .NE. 0.0 ) THEN
533 dz_z = max( dz_z, dyk / yk )
534 ELSE IF ( dyk .NE. 0.0 ) THEN
535 dz_z = hugeval
536 END IF
537
538 ymin = min( ymin, yk )
539
540 normy = max( normy, yk )
541
542 IF ( colequ ) THEN
543 normx = max( normx, yk * c( i ) )
544 normdx = max( normdx, dyk * c( i ) )
545 ELSE
546 normx = normy
547 normdx = max( normdx, dyk )
548 END IF
549 END DO
550
551 IF ( normx .NE. 0.0 ) THEN
552 dx_x = normdx / normx
553 ELSE IF ( normdx .EQ. 0.0 ) THEN
554 dx_x = 0.0
555 ELSE
556 dx_x = hugeval
557 END IF
558
559 dxrat = normdx / prevnormdx
560 dzrat = dz_z / prev_dz_z
561*
562* Check termination criteria
563*
564 IF (.NOT.ignore_cwise
565 $ .AND. ymin*rcond .LT. incr_thresh*normy
566 $ .AND. y_prec_state .LT. extra_y)
567 $ incr_prec = .true.
568
569 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
570 $ x_state = working_state
571 IF ( x_state .EQ. working_state ) THEN
572 IF ( dx_x .LE. eps ) THEN
573 x_state = conv_state
574 ELSE IF ( dxrat .GT. rthresh ) THEN
575 IF ( y_prec_state .NE. extra_y ) THEN
576 incr_prec = .true.
577 ELSE
578 x_state = noprog_state
579 END IF
580 ELSE
581 IF ( dxrat .GT. dxratmax ) dxratmax = dxrat
582 END IF
583 IF ( x_state .GT. working_state ) final_dx_x = dx_x
584 END IF
585
586 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
587 $ z_state = working_state
588 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
589 $ z_state = working_state
590 IF ( z_state .EQ. working_state ) THEN
591 IF ( dz_z .LE. eps ) THEN
592 z_state = conv_state
593 ELSE IF ( dz_z .GT. dz_ub ) THEN
594 z_state = unstable_state
595 dzratmax = 0.0
596 final_dz_z = hugeval
597 ELSE IF ( dzrat .GT. rthresh ) THEN
598 IF ( y_prec_state .NE. extra_y ) THEN
599 incr_prec = .true.
600 ELSE
601 z_state = noprog_state
602 END IF
603 ELSE
604 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
605 END IF
606 IF ( z_state .GT. working_state ) final_dz_z = dz_z
607 END IF
608*
609* Exit if both normwise and componentwise stopped working,
610* but if componentwise is unstable, let it go at least two
611* iterations.
612*
613 IF ( x_state.NE.working_state ) THEN
614 IF ( ignore_cwise) GOTO 666
615 IF ( z_state.EQ.noprog_state .OR. z_state.EQ.conv_state )
616 $ GOTO 666
617 IF ( z_state.EQ.unstable_state .AND. cnt.GT.1 ) GOTO 666
618 END IF
619
620 IF ( incr_prec ) THEN
621 incr_prec = .false.
622 y_prec_state = y_prec_state + 1
623 DO i = 1, n
624 y_tail( i ) = 0.0
625 END DO
626 END IF
627
628 prevnormdx = normdx
629 prev_dz_z = dz_z
630*
631* Update soluton.
632*
633 IF ( y_prec_state .LT. extra_y ) THEN
634 CALL saxpy( n, 1.0, dy, 1, y( 1, j ), 1 )
635 ELSE
636 CALL sla_wwaddw( n, y( 1, j ), y_tail, dy )
637 END IF
638
639 END DO
640* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT.
641 666 CONTINUE
642*
643* Set final_* when cnt hits ithresh.
644*
645 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
646 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
647*
648* Compute error bounds
649*
650 IF (n_norms .GE. 1) THEN
651 errs_n( j, la_linrx_err_i ) =
652 $ final_dx_x / (1 - dxratmax)
653 END IF
654 IF ( n_norms .GE. 2 ) THEN
655 errs_c( j, la_linrx_err_i ) =
656 $ final_dz_z / (1 - dzratmax)
657 END IF
658*
659* Compute componentwise relative backward error from formula
660* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
661* where abs(Z) is the componentwise absolute value of the matrix
662* or vector Z.
663*
664* Compute residual RES = B_s - op(A_s) * Y,
665* op(A) = A, A**T, or A**H depending on TRANS (and type).
666*
667 CALL scopy( n, b( 1, j ), 1, res, 1 )
668 CALL sgemv( trans, n, n, -1.0, a, lda, y(1,j), 1, 1.0, res, 1 )
669
670 DO i = 1, n
671 ayb( i ) = abs( b( i, j ) )
672 END DO
673*
674* Compute abs(op(A_s))*abs(Y) + abs(B_s).
675*
676 CALL sla_geamv ( trans_type, n, n, 1.0,
677 $ a, lda, y(1, j), 1, 1.0, ayb, 1 )
678
679 CALL sla_lin_berr ( n, n, 1, res, ayb, berr_out( j ) )
680*
681* End of loop for each RHS.
682*
683 END DO
684*
685 RETURN
686*
687* End of SLA_GERFSX_EXTENDED
688*
chla_transtype
character *1 function chla_transtype(trans)
CHLA_TRANSTYPE
Definition chla_transtype.f:58
sla_geamv
subroutine sla_geamv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.
Definition sla_geamv.f:174
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_gerpvgrw()

real function sla_gerpvgrw ( integer n,
integer ncols,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldaf, * ) af,
integer ldaf )

SLA_GERPVGRW

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

Purpose:
!>
!> SLA_GERPVGRW 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]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]NCOLS
!>          NCOLS is INTEGER
!>     The number of columns of the matrix A. NCOLS >= 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 factors L and U from the factorization
!>     A = P*L*U as computed by SGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 96 of file sla_gerpvgrw.f.

97*
98* -- LAPACK computational routine --
99* -- LAPACK is a software package provided by Univ. of Tennessee, --
100* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
101*
102* .. Scalar Arguments ..
103 INTEGER N, NCOLS, LDA, LDAF
104* ..
105* .. Array Arguments ..
106 REAL A( LDA, * ), AF( LDAF, * )
107* ..
108*
109* =====================================================================
110*
111* .. Local Scalars ..
112 INTEGER I, J
113 REAL AMAX, UMAX, RPVGRW
114* ..
115* .. Intrinsic Functions ..
116 INTRINSIC abs, max, min
117* ..
118* .. Executable Statements ..
119*
120 rpvgrw = 1.0
121
122 DO j = 1, ncols
123 amax = 0.0
124 umax = 0.0
125 DO i = 1, n
126 amax = max( abs( a( i, j ) ), amax )
127 END DO
128 DO i = 1, j
129 umax = max( abs( af( i, j ) ), umax )
130 END DO
131 IF ( umax /= 0.0 ) THEN
132 rpvgrw = min( amax / umax, rpvgrw )
133 END IF
134 END DO
135 sla_gerpvgrw = rpvgrw
136*
137* End of SLA_GERPVGRW
138*
sla_gerpvgrw
real function sla_gerpvgrw(n, ncols, a, lda, af, ldaf)
SLA_GERPVGRW
Definition sla_gerpvgrw.f:97

◆ slaorhr_col_getrfnp()

subroutine slaorhr_col_getrfnp ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
integer info )

SLAORHR_COL_GETRFNP

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

Purpose:
!>
!> SLAORHR_COL_GETRFNP computes the modified LU factorization without
!> pivoting of a real general M-by-N matrix A. The factorization has
!> the form:
!>
!>     A - S = L * U,
!>
!> where:
!>    S is a m-by-n diagonal sign matrix with the diagonal D, so that
!>    D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed
!>    as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing
!>    i-1 steps of Gaussian elimination. This means that the diagonal
!>    element at each step of  Gaussian elimination is
!>    at least one in absolute value (so that division-by-zero not
!>    not possible during the division by the diagonal element);
!>
!>    L is a M-by-N lower triangular matrix with unit diagonal elements
!>    (lower trapezoidal if M > N);
!>
!>    and U is a M-by-N upper triangular matrix
!>    (upper trapezoidal if M < N).
!>
!> This routine is an auxiliary routine used in the Householder
!> reconstruction routine SORHR_COL. In SORHR_COL, this routine is
!> applied to an M-by-N matrix A with orthonormal columns, where each
!> element is bounded by one in absolute value. With the choice of
!> the matrix S above, one can show that the diagonal element at each
!> step of Gaussian elimination is the largest (in absolute value) in
!> the column on or below the diagonal, so that no pivoting is required
!> for numerical stability [1].
!>
!> For more details on the Householder reconstruction algorithm,
!> including the modified LU factorization, see [1].
!>
!> This is the blocked right-looking version of the algorithm,
!> calling Level 3 BLAS to update the submatrix. To factorize a block,
!> this routine calls the recursive routine SLAORHR_COL_GETRFNP2.
!>
!> [1] ,
!>     G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
!>     E. Solomonik, J. Parallel Distrib. Comput.,
!>     vol. 85, pp. 3-31, 2015.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A-S=L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is REAL array, dimension min(M,N)
!>          The diagonal elements of the diagonal M-by-N sign matrix S,
!>          D(i) = S(i,i), where 1 <= i <= min(M,N). The elements can
!>          be only plus or minus one.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November 2019, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!>

Definition at line 145 of file slaorhr_col_getrfnp.f.

146 IMPLICIT NONE
147*
148* -- LAPACK computational routine --
149* -- LAPACK is a software package provided by Univ. of Tennessee, --
150* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151*
152* .. Scalar Arguments ..
153 INTEGER INFO, LDA, M, N
154* ..
155* .. Array Arguments ..
156 REAL A( LDA, * ), D( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ONE
163 parameter( one = 1.0e+0 )
164* ..
165* .. Local Scalars ..
166 INTEGER IINFO, J, JB, NB
167* ..
168* .. External Subroutines ..
169 EXTERNAL sgemm, slaorhr_col_getrfnp2, strsm, xerbla
170* ..
171* .. External Functions ..
172 INTEGER ILAENV
173 EXTERNAL ilaenv
174* ..
175* .. Intrinsic Functions ..
176 INTRINSIC max, min
177* ..
178* .. Executable Statements ..
179*
180* Test the input parameters.
181*
182 info = 0
183 IF( m.LT.0 ) THEN
184 info = -1
185 ELSE IF( n.LT.0 ) THEN
186 info = -2
187 ELSE IF( lda.LT.max( 1, m ) ) THEN
188 info = -4
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'SLAORHR_COL_GETRFNP', -info )
192 RETURN
193 END IF
194*
195* Quick return if possible
196*
197 IF( min( m, n ).EQ.0 )
198 $ RETURN
199*
200* Determine the block size for this environment.
201*
202
203 nb = ilaenv( 1, 'SLAORHR_COL_GETRFNP', ' ', m, n, -1, -1 )
204
205 IF( nb.LE.1 .OR. nb.GE.min( m, n ) ) THEN
206*
207* Use unblocked code.
208*
209 CALL slaorhr_col_getrfnp2( m, n, a, lda, d, info )
210 ELSE
211*
212* Use blocked code.
213*
214 DO j = 1, min( m, n ), nb
215 jb = min( min( m, n )-j+1, nb )
216*
217* Factor diagonal and subdiagonal blocks.
218*
219 CALL slaorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,
220 $ d( j ), iinfo )
221*
222 IF( j+jb.LE.n ) THEN
223*
224* Compute block row of U.
225*
226 CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', jb,
227 $ n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ),
228 $ lda )
229 IF( j+jb.LE.m ) THEN
230*
231* Update trailing submatrix.
232*
233 CALL sgemm( 'No transpose', 'No transpose', m-j-jb+1,
234 $ n-j-jb+1, jb, -one, a( j+jb, j ), lda,
235 $ a( j, j+jb ), lda, one, a( j+jb, j+jb ),
236 $ lda )
237 END IF
238 END IF
239 END DO
240 END IF
241 RETURN
242*
243* End of SLAORHR_COL_GETRFNP
244*
slaorhr_col_getrfnp2
recursive subroutine slaorhr_col_getrfnp2(m, n, a, lda, d, info)
SLAORHR_COL_GETRFNP2
Definition slaorhr_col_getrfnp2.f:167

◆ slaorhr_col_getrfnp2()

recursive subroutine slaorhr_col_getrfnp2 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
integer info )

SLAORHR_COL_GETRFNP2

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

Purpose:
!>
!> SLAORHR_COL_GETRFNP2 computes the modified LU factorization without
!> pivoting of a real general M-by-N matrix A. The factorization has
!> the form:
!>
!>     A - S = L * U,
!>
!> where:
!>    S is a m-by-n diagonal sign matrix with the diagonal D, so that
!>    D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed
!>    as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing
!>    i-1 steps of Gaussian elimination. This means that the diagonal
!>    element at each step of  Gaussian elimination is at
!>    least one in absolute value (so that division-by-zero not
!>    possible during the division by the diagonal element);
!>
!>    L is a M-by-N lower triangular matrix with unit diagonal elements
!>    (lower trapezoidal if M > N);
!>
!>    and U is a M-by-N upper triangular matrix
!>    (upper trapezoidal if M < N).
!>
!> This routine is an auxiliary routine used in the Householder
!> reconstruction routine SORHR_COL. In SORHR_COL, this routine is
!> applied to an M-by-N matrix A with orthonormal columns, where each
!> element is bounded by one in absolute value. With the choice of
!> the matrix S above, one can show that the diagonal element at each
!> step of Gaussian elimination is the largest (in absolute value) in
!> the column on or below the diagonal, so that no pivoting is required
!> for numerical stability [1].
!>
!> For more details on the Householder reconstruction algorithm,
!> including the modified LU factorization, see [1].
!>
!> This is the recursive version of the LU factorization algorithm.
!> Denote A - S by B. The algorithm divides the matrix B into four
!> submatrices:
!>
!>        [  B11 | B12  ]  where B11 is n1 by n1,
!>    B = [ -----|----- ]        B21 is (m-n1) by n1,
!>        [  B21 | B22  ]        B12 is n1 by n2,
!>                               B22 is (m-n1) by n2,
!>                               with n1 = min(m,n)/2, n2 = n-n1.
!>
!>
!> The subroutine calls itself to factor B11, solves for B21,
!> solves for B12, updates B22, then calls itself to factor B22.
!>
!> For more details on the recursive LU algorithm, see [2].
!>
!> SLAORHR_COL_GETRFNP2 is called to factorize a block by the blocked
!> routine SLAORHR_COL_GETRFNP, which uses blocked code calling
!> Level 3 BLAS to update the submatrix. However, SLAORHR_COL_GETRFNP2
!> is self-sufficient and can be used without SLAORHR_COL_GETRFNP.
!>
!> [1] ,
!>     G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
!>     E. Solomonik, J. Parallel Distrib. Comput.,
!>     vol. 85, pp. 3-31, 2015.
!>
!> [2] , F. Gustavson, IBM J. of Res. and Dev.,
!>     vol. 41, no. 6, pp. 737-755, 1997.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A-S=L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is REAL array, dimension min(M,N)
!>          The diagonal elements of the diagonal M-by-N sign matrix S,
!>          D(i) = S(i,i), where 1 <= i <= min(M,N). The elements can
!>          be only plus or minus one.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November 2019, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!>

Definition at line 166 of file slaorhr_col_getrfnp2.f.

167 IMPLICIT NONE
168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 INTEGER INFO, LDA, M, N
175* ..
176* .. Array Arguments ..
177 REAL A( LDA, * ), D( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ONE
184 parameter( one = 1.0e+0 )
185* ..
186* .. Local Scalars ..
187 REAL SFMIN
188 INTEGER I, IINFO, N1, N2
189* ..
190* .. External Functions ..
191 REAL SLAMCH
192 EXTERNAL slamch
193* ..
194* .. External Subroutines ..
195 EXTERNAL sgemm, sscal, strsm, xerbla
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC abs, sign, max, min
199* ..
200* .. Executable Statements ..
201*
202* Test the input parameters
203*
204 info = 0
205 IF( m.LT.0 ) THEN
206 info = -1
207 ELSE IF( n.LT.0 ) THEN
208 info = -2
209 ELSE IF( lda.LT.max( 1, m ) ) THEN
210 info = -4
211 END IF
212 IF( info.NE.0 ) THEN
213 CALL xerbla( 'SLAORHR_COL_GETRFNP2', -info )
214 RETURN
215 END IF
216*
217* Quick return if possible
218*
219 IF( min( m, n ).EQ.0 )
220 $ RETURN
221
222 IF ( m.EQ.1 ) THEN
223*
224* One row case, (also recursion termination case),
225* use unblocked code
226*
227* Transfer the sign
228*
229 d( 1 ) = -sign( one, a( 1, 1 ) )
230*
231* Construct the row of U
232*
233 a( 1, 1 ) = a( 1, 1 ) - d( 1 )
234*
235 ELSE IF( n.EQ.1 ) THEN
236*
237* One column case, (also recursion termination case),
238* use unblocked code
239*
240* Transfer the sign
241*
242 d( 1 ) = -sign( one, a( 1, 1 ) )
243*
244* Construct the row of U
245*
246 a( 1, 1 ) = a( 1, 1 ) - d( 1 )
247*
248* Scale the elements 2:M of the column
249*
250* Determine machine safe minimum
251*
252 sfmin = slamch('S')
253*
254* Construct the subdiagonal elements of L
255*
256 IF( abs( a( 1, 1 ) ) .GE. sfmin ) THEN
257 CALL sscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 )
258 ELSE
259 DO i = 2, m
260 a( i, 1 ) = a( i, 1 ) / a( 1, 1 )
261 END DO
262 END IF
263*
264 ELSE
265*
266* Divide the matrix B into four submatrices
267*
268 n1 = min( m, n ) / 2
269 n2 = n-n1
270
271*
272* Factor B11, recursive call
273*
274 CALL slaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo )
275*
276* Solve for B21
277*
278 CALL strsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,
279 $ a( n1+1, 1 ), lda )
280*
281* Solve for B12
282*
283 CALL strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,
284 $ a( 1, n1+1 ), lda )
285*
286* Update B22, i.e. compute the Schur complement
287* B22 := B22 - B21*B12
288*
289 CALL sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,
290 $ a( 1, n1+1 ), lda, one, a( n1+1, n1+1 ), lda )
291*
292* Factor B22, recursive call
293*
294 CALL slaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,
295 $ d( n1+1 ), iinfo )
296*
297 END IF
298 RETURN
299*
300* End of SLAORHR_COL_GETRFNP2
301*

◆ stgevc()

subroutine stgevc ( character side,
character howmny,
logical, dimension( * ) select,
integer n,
real, dimension( lds, * ) s,
integer lds,
real, dimension( ldp, * ) p,
integer ldp,
real, dimension( ldvl, * ) vl,
integer ldvl,
real, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
real, dimension( * ) work,
integer info )

STGEVC

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

Purpose:
!>
!> STGEVC computes some or all of the right and/or left eigenvectors of
!> a pair of real matrices (S,P), where S is a quasi-triangular matrix
!> and P is upper triangular.  Matrix pairs of this type are produced by
!> the generalized Schur factorization of a matrix pair (A,B):
!>
!>    A = Q*S*Z**T,  B = Q*P*Z**T
!>
!> as computed by SGGHRD + SHGEQZ.
!>
!> The right eigenvector x and the left eigenvector y of (S,P)
!> corresponding to an eigenvalue w are defined by:
!>
!>    S*x = w*P*x,  (y**H)*S = w*(y**H)*P,
!>
!> where y**H denotes the conjugate tranpose of y.
!> The eigenvalues are not input to this routine, but are computed
!> directly from the diagonal blocks of S and P.
!>
!> This routine returns the matrices X and/or Y of right and left
!> eigenvectors of (S,P), or the products Z*X and/or Q*Y,
!> where Z and Q are input matrices.
!> If Q and Z are the orthogonal factors from the generalized Schur
!> factorization of a matrix pair (A,B), then Z*X and Q*Y
!> are the matrices of right and left eigenvectors of (A,B).
!>
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'R': compute right eigenvectors only;
!>          = 'L': compute left eigenvectors only;
!>          = 'B': compute both right and left eigenvectors.
!>
[in]HOWMNY
!>          HOWMNY is CHARACTER*1
!>          = 'A': compute all right and/or left eigenvectors;
!>          = 'B': compute all right and/or left eigenvectors,
!>                 backtransformed by the matrices in VR and/or VL;
!>          = 'S': compute selected right and/or left eigenvectors,
!>                 specified by the logical array SELECT.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY='S', SELECT specifies the eigenvectors to be
!>          computed.  If w(j) is a real eigenvalue, the corresponding
!>          real eigenvector is computed if SELECT(j) is .TRUE..
!>          If w(j) and w(j+1) are the real and imaginary parts of a
!>          complex eigenvalue, the corresponding complex eigenvector
!>          is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
!>          and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
!>          set to .FALSE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices S and P.  N >= 0.
!>
[in]S
!>          S is REAL array, dimension (LDS,N)
!>          The upper quasi-triangular matrix S from a generalized Schur
!>          factorization, as computed by SHGEQZ.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of array S.  LDS >= max(1,N).
!>
[in]P
!>          P is REAL array, dimension (LDP,N)
!>          The upper triangular matrix P from a generalized Schur
!>          factorization, as computed by SHGEQZ.
!>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
!>          of S must be in positive diagonal form.
!>
[in]LDP
!>          LDP is INTEGER
!>          The leading dimension of array P.  LDP >= max(1,N).
!>
[in,out]VL
!>          VL is REAL array, dimension (LDVL,MM)
!>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!>          contain an N-by-N matrix Q (usually the orthogonal matrix Q
!>          of left Schur vectors returned by SHGEQZ).
!>          On exit, if SIDE = 'L' or 'B', VL contains:
!>          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
!>          if HOWMNY = 'B', the matrix Q*Y;
!>          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
!>                      SELECT, stored consecutively in the columns of
!>                      VL, in the same order as their eigenvalues.
!>
!>          A complex eigenvector corresponding to a complex eigenvalue
!>          is stored in two consecutive columns, the first holding the
!>          real part, and the second the imaginary part.
!>
!>          Not referenced if SIDE = 'R'.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of array VL.  LDVL >= 1, and if
!>          SIDE = 'L' or 'B', LDVL >= N.
!>
[in,out]VR
!>          VR is REAL array, dimension (LDVR,MM)
!>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!>          contain an N-by-N matrix Z (usually the orthogonal matrix Z
!>          of right Schur vectors returned by SHGEQZ).
!>
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
!>          if HOWMNY = 'B' or 'b', the matrix Z*X;
!>          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
!>                      specified by SELECT, stored consecutively in the
!>                      columns of VR, in the same order as their
!>                      eigenvalues.
!>
!>          A complex eigenvector corresponding to a complex eigenvalue
!>          is stored in two consecutive columns, the first holding the
!>          real part and the second the imaginary part.
!>
!>          Not referenced if SIDE = 'L'.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1, and if
!>          SIDE = 'R' or 'B', LDVR >= N.
!>
[in]MM
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR actually
!>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
!>          is set to N.  Each selected real eigenvector occupies one
!>          column and each selected complex eigenvector occupies two
!>          columns.
!>
[out]WORK
!>          WORK is REAL array, dimension (6*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex
!>                eigenvalue.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Allocation of workspace:
!>  ---------- -- ---------
!>
!>     WORK( j ) = 1-norm of j-th column of A, above the diagonal
!>     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
!>     WORK( 2*N+1:3*N ) = real part of eigenvector
!>     WORK( 3*N+1:4*N ) = imaginary part of eigenvector
!>     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
!>     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
!>
!>  Rowwise vs. columnwise solution methods:
!>  ------- --  ---------- -------- -------
!>
!>  Finding a generalized eigenvector consists basically of solving the
!>  singular triangular system
!>
!>   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)
!>
!>  Consider finding the i-th right eigenvector (assume all eigenvalues
!>  are real). The equation to be solved is:
!>       n                   i
!>  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1
!>      k=j                 k=j
!>
!>  where  C = (A - w B)  (The components v(i+1:n) are 0.)
!>
!>  The  method is:
!>
!>  (1)  v(i) := 1
!>  for j = i-1,. . .,1:
!>                          i
!>      (2) compute  s = - sum C(j,k) v(k)   and
!>                        k=j+1
!>
!>      (3) v(j) := s / C(j,j)
!>
!>  Step 2 is sometimes called the  step, since it is an
!>  inner product between the j-th row and the portion of the eigenvector
!>  that has been computed so far.
!>
!>  The  method consists basically in doing the sums
!>  for all the rows in parallel.  As each v(j) is computed, the
!>  contribution of v(j) times the j-th column of C is added to the
!>  partial sums.  Since FORTRAN arrays are stored columnwise, this has
!>  the advantage that at each step, the elements of C that are accessed
!>  are adjacent to one another, whereas with the rowwise method, the
!>  elements accessed at a step are spaced LDS (and LDP) words apart.
!>
!>  When finding left eigenvectors, the matrix in question is the
!>  transpose of the one in storage, so the rowwise method then
!>  actually accesses columns of A and B at each step, and so is the
!>  preferred method.
!>

Definition at line 293 of file stgevc.f.

295*
296* -- LAPACK computational routine --
297* -- LAPACK is a software package provided by Univ. of Tennessee, --
298* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
299*
300* .. Scalar Arguments ..
301 CHARACTER HOWMNY, SIDE
302 INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
303* ..
304* .. Array Arguments ..
305 LOGICAL SELECT( * )
306 REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
307 $ VR( LDVR, * ), WORK( * )
308* ..
309*
310*
311* =====================================================================
312*
313* .. Parameters ..
314 REAL ZERO, ONE, SAFETY
315 parameter( zero = 0.0e+0, one = 1.0e+0,
316 $ safety = 1.0e+2 )
317* ..
318* .. Local Scalars ..
319 LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
320 $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
321 INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
322 $ J, JA, JC, JE, JR, JW, NA, NW
323 REAL ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
324 $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
325 $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
326 $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
327 $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
328 $ XSCALE
329* ..
330* .. Local Arrays ..
331 REAL BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
332 $ SUMP( 2, 2 )
333* ..
334* .. External Functions ..
335 LOGICAL LSAME
336 REAL SLAMCH
337 EXTERNAL lsame, slamch
338* ..
339* .. External Subroutines ..
340 EXTERNAL sgemv, slabad, slacpy, slag2, slaln2, xerbla
341* ..
342* .. Intrinsic Functions ..
343 INTRINSIC abs, max, min
344* ..
345* .. Executable Statements ..
346*
347* Decode and Test the input parameters
348*
349 IF( lsame( howmny, 'A' ) ) THEN
350 ihwmny = 1
351 ilall = .true.
352 ilback = .false.
353 ELSE IF( lsame( howmny, 'S' ) ) THEN
354 ihwmny = 2
355 ilall = .false.
356 ilback = .false.
357 ELSE IF( lsame( howmny, 'B' ) ) THEN
358 ihwmny = 3
359 ilall = .true.
360 ilback = .true.
361 ELSE
362 ihwmny = -1
363 ilall = .true.
364 END IF
365*
366 IF( lsame( side, 'R' ) ) THEN
367 iside = 1
368 compl = .false.
369 compr = .true.
370 ELSE IF( lsame( side, 'L' ) ) THEN
371 iside = 2
372 compl = .true.
373 compr = .false.
374 ELSE IF( lsame( side, 'B' ) ) THEN
375 iside = 3
376 compl = .true.
377 compr = .true.
378 ELSE
379 iside = -1
380 END IF
381*
382 info = 0
383 IF( iside.LT.0 ) THEN
384 info = -1
385 ELSE IF( ihwmny.LT.0 ) THEN
386 info = -2
387 ELSE IF( n.LT.0 ) THEN
388 info = -4
389 ELSE IF( lds.LT.max( 1, n ) ) THEN
390 info = -6
391 ELSE IF( ldp.LT.max( 1, n ) ) THEN
392 info = -8
393 END IF
394 IF( info.NE.0 ) THEN
395 CALL xerbla( 'STGEVC', -info )
396 RETURN
397 END IF
398*
399* Count the number of eigenvectors to be computed
400*
401 IF( .NOT.ilall ) THEN
402 im = 0
403 ilcplx = .false.
404 DO 10 j = 1, n
405 IF( ilcplx ) THEN
406 ilcplx = .false.
407 GO TO 10
408 END IF
409 IF( j.LT.n ) THEN
410 IF( s( j+1, j ).NE.zero )
411 $ ilcplx = .true.
412 END IF
413 IF( ilcplx ) THEN
414 IF( SELECT( j ) .OR. SELECT( j+1 ) )
415 $ im = im + 2
416 ELSE
417 IF( SELECT( j ) )
418 $ im = im + 1
419 END IF
420 10 CONTINUE
421 ELSE
422 im = n
423 END IF
424*
425* Check 2-by-2 diagonal blocks of A, B
426*
427 ilabad = .false.
428 ilbbad = .false.
429 DO 20 j = 1, n - 1
430 IF( s( j+1, j ).NE.zero ) THEN
431 IF( p( j, j ).EQ.zero .OR. p( j+1, j+1 ).EQ.zero .OR.
432 $ p( j, j+1 ).NE.zero )ilbbad = .true.
433 IF( j.LT.n-1 ) THEN
434 IF( s( j+2, j+1 ).NE.zero )
435 $ ilabad = .true.
436 END IF
437 END IF
438 20 CONTINUE
439*
440 IF( ilabad ) THEN
441 info = -5
442 ELSE IF( ilbbad ) THEN
443 info = -7
444 ELSE IF( compl .AND. ldvl.LT.n .OR. ldvl.LT.1 ) THEN
445 info = -10
446 ELSE IF( compr .AND. ldvr.LT.n .OR. ldvr.LT.1 ) THEN
447 info = -12
448 ELSE IF( mm.LT.im ) THEN
449 info = -13
450 END IF
451 IF( info.NE.0 ) THEN
452 CALL xerbla( 'STGEVC', -info )
453 RETURN
454 END IF
455*
456* Quick return if possible
457*
458 m = im
459 IF( n.EQ.0 )
460 $ RETURN
461*
462* Machine Constants
463*
464 safmin = slamch( 'Safe minimum' )
465 big = one / safmin
466 CALL slabad( safmin, big )
467 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
468 small = safmin*n / ulp
469 big = one / small
470 bignum = one / ( safmin*n )
471*
472* Compute the 1-norm of each column of the strictly upper triangular
473* part (i.e., excluding all elements belonging to the diagonal
474* blocks) of A and B to check for possible overflow in the
475* triangular solver.
476*
477 anorm = abs( s( 1, 1 ) )
478 IF( n.GT.1 )
479 $ anorm = anorm + abs( s( 2, 1 ) )
480 bnorm = abs( p( 1, 1 ) )
481 work( 1 ) = zero
482 work( n+1 ) = zero
483*
484 DO 50 j = 2, n
485 temp = zero
486 temp2 = zero
487 IF( s( j, j-1 ).EQ.zero ) THEN
488 iend = j - 1
489 ELSE
490 iend = j - 2
491 END IF
492 DO 30 i = 1, iend
493 temp = temp + abs( s( i, j ) )
494 temp2 = temp2 + abs( p( i, j ) )
495 30 CONTINUE
496 work( j ) = temp
497 work( n+j ) = temp2
498 DO 40 i = iend + 1, min( j+1, n )
499 temp = temp + abs( s( i, j ) )
500 temp2 = temp2 + abs( p( i, j ) )
501 40 CONTINUE
502 anorm = max( anorm, temp )
503 bnorm = max( bnorm, temp2 )
504 50 CONTINUE
505*
506 ascale = one / max( anorm, safmin )
507 bscale = one / max( bnorm, safmin )
508*
509* Left eigenvectors
510*
511 IF( compl ) THEN
512 ieig = 0
513*
514* Main loop over eigenvalues
515*
516 ilcplx = .false.
517 DO 220 je = 1, n
518*
519* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
520* (b) this would be the second of a complex pair.
521* Check for complex eigenvalue, so as to be sure of which
522* entry(-ies) of SELECT to look at.
523*
524 IF( ilcplx ) THEN
525 ilcplx = .false.
526 GO TO 220
527 END IF
528 nw = 1
529 IF( je.LT.n ) THEN
530 IF( s( je+1, je ).NE.zero ) THEN
531 ilcplx = .true.
532 nw = 2
533 END IF
534 END IF
535 IF( ilall ) THEN
536 ilcomp = .true.
537 ELSE IF( ilcplx ) THEN
538 ilcomp = SELECT( je ) .OR. SELECT( je+1 )
539 ELSE
540 ilcomp = SELECT( je )
541 END IF
542 IF( .NOT.ilcomp )
543 $ GO TO 220
544*
545* Decide if (a) singular pencil, (b) real eigenvalue, or
546* (c) complex eigenvalue.
547*
548 IF( .NOT.ilcplx ) THEN
549 IF( abs( s( je, je ) ).LE.safmin .AND.
550 $ abs( p( je, je ) ).LE.safmin ) THEN
551*
552* Singular matrix pencil -- return unit eigenvector
553*
554 ieig = ieig + 1
555 DO 60 jr = 1, n
556 vl( jr, ieig ) = zero
557 60 CONTINUE
558 vl( ieig, ieig ) = one
559 GO TO 220
560 END IF
561 END IF
562*
563* Clear vector
564*
565 DO 70 jr = 1, nw*n
566 work( 2*n+jr ) = zero
567 70 CONTINUE
568* T
569* Compute coefficients in ( a A - b B ) y = 0
570* a is ACOEF
571* b is BCOEFR + i*BCOEFI
572*
573 IF( .NOT.ilcplx ) THEN
574*
575* Real eigenvalue
576*
577 temp = one / max( abs( s( je, je ) )*ascale,
578 $ abs( p( je, je ) )*bscale, safmin )
579 salfar = ( temp*s( je, je ) )*ascale
580 sbeta = ( temp*p( je, je ) )*bscale
581 acoef = sbeta*ascale
582 bcoefr = salfar*bscale
583 bcoefi = zero
584*
585* Scale to avoid underflow
586*
587 scale = one
588 lsa = abs( sbeta ).GE.safmin .AND. abs( acoef ).LT.small
589 lsb = abs( salfar ).GE.safmin .AND. abs( bcoefr ).LT.
590 $ small
591 IF( lsa )
592 $ scale = ( small / abs( sbeta ) )*min( anorm, big )
593 IF( lsb )
594 $ scale = max( scale, ( small / abs( salfar ) )*
595 $ min( bnorm, big ) )
596 IF( lsa .OR. lsb ) THEN
597 scale = min( scale, one /
598 $ ( safmin*max( one, abs( acoef ),
599 $ abs( bcoefr ) ) ) )
600 IF( lsa ) THEN
601 acoef = ascale*( scale*sbeta )
602 ELSE
603 acoef = scale*acoef
604 END IF
605 IF( lsb ) THEN
606 bcoefr = bscale*( scale*salfar )
607 ELSE
608 bcoefr = scale*bcoefr
609 END IF
610 END IF
611 acoefa = abs( acoef )
612 bcoefa = abs( bcoefr )
613*
614* First component is 1
615*
616 work( 2*n+je ) = one
617 xmax = one
618 ELSE
619*
620* Complex eigenvalue
621*
622 CALL slag2( s( je, je ), lds, p( je, je ), ldp,
623 $ safmin*safety, acoef, temp, bcoefr, temp2,
624 $ bcoefi )
625 bcoefi = -bcoefi
626 IF( bcoefi.EQ.zero ) THEN
627 info = je
628 RETURN
629 END IF
630*
631* Scale to avoid over/underflow
632*
633 acoefa = abs( acoef )
634 bcoefa = abs( bcoefr ) + abs( bcoefi )
635 scale = one
636 IF( acoefa*ulp.LT.safmin .AND. acoefa.GE.safmin )
637 $ scale = ( safmin / ulp ) / acoefa
638 IF( bcoefa*ulp.LT.safmin .AND. bcoefa.GE.safmin )
639 $ scale = max( scale, ( safmin / ulp ) / bcoefa )
640 IF( safmin*acoefa.GT.ascale )
641 $ scale = ascale / ( safmin*acoefa )
642 IF( safmin*bcoefa.GT.bscale )
643 $ scale = min( scale, bscale / ( safmin*bcoefa ) )
644 IF( scale.NE.one ) THEN
645 acoef = scale*acoef
646 acoefa = abs( acoef )
647 bcoefr = scale*bcoefr
648 bcoefi = scale*bcoefi
649 bcoefa = abs( bcoefr ) + abs( bcoefi )
650 END IF
651*
652* Compute first two components of eigenvector
653*
654 temp = acoef*s( je+1, je )
655 temp2r = acoef*s( je, je ) - bcoefr*p( je, je )
656 temp2i = -bcoefi*p( je, je )
657 IF( abs( temp ).GT.abs( temp2r )+abs( temp2i ) ) THEN
658 work( 2*n+je ) = one
659 work( 3*n+je ) = zero
660 work( 2*n+je+1 ) = -temp2r / temp
661 work( 3*n+je+1 ) = -temp2i / temp
662 ELSE
663 work( 2*n+je+1 ) = one
664 work( 3*n+je+1 ) = zero
665 temp = acoef*s( je, je+1 )
666 work( 2*n+je ) = ( bcoefr*p( je+1, je+1 )-acoef*
667 $ s( je+1, je+1 ) ) / temp
668 work( 3*n+je ) = bcoefi*p( je+1, je+1 ) / temp
669 END IF
670 xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),
671 $ abs( work( 2*n+je+1 ) )+abs( work( 3*n+je+1 ) ) )
672 END IF
673*
674 dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin )
675*
676* T
677* Triangular solve of (a A - b B) y = 0
678*
679* T
680* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
681*
682 il2by2 = .false.
683*
684 DO 160 j = je + nw, n
685 IF( il2by2 ) THEN
686 il2by2 = .false.
687 GO TO 160
688 END IF
689*
690 na = 1
691 bdiag( 1 ) = p( j, j )
692 IF( j.LT.n ) THEN
693 IF( s( j+1, j ).NE.zero ) THEN
694 il2by2 = .true.
695 bdiag( 2 ) = p( j+1, j+1 )
696 na = 2
697 END IF
698 END IF
699*
700* Check whether scaling is necessary for dot products
701*
702 xscale = one / max( one, xmax )
703 temp = max( work( j ), work( n+j ),
704 $ acoefa*work( j )+bcoefa*work( n+j ) )
705 IF( il2by2 )
706 $ temp = max( temp, work( j+1 ), work( n+j+1 ),
707 $ acoefa*work( j+1 )+bcoefa*work( n+j+1 ) )
708 IF( temp.GT.bignum*xscale ) THEN
709 DO 90 jw = 0, nw - 1
710 DO 80 jr = je, j - 1
711 work( ( jw+2 )*n+jr ) = xscale*
712 $ work( ( jw+2 )*n+jr )
713 80 CONTINUE
714 90 CONTINUE
715 xmax = xmax*xscale
716 END IF
717*
718* Compute dot products
719*
720* j-1
721* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
722* k=je
723*
724* To reduce the op count, this is done as
725*
726* _ j-1 _ j-1
727* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) )
728* k=je k=je
729*
730* which may cause underflow problems if A or B are close
731* to underflow. (E.g., less than SMALL.)
732*
733*
734 DO 120 jw = 1, nw
735 DO 110 ja = 1, na
736 sums( ja, jw ) = zero
737 sump( ja, jw ) = zero
738*
739 DO 100 jr = je, j - 1
740 sums( ja, jw ) = sums( ja, jw ) +
741 $ s( jr, j+ja-1 )*
742 $ work( ( jw+1 )*n+jr )
743 sump( ja, jw ) = sump( ja, jw ) +
744 $ p( jr, j+ja-1 )*
745 $ work( ( jw+1 )*n+jr )
746 100 CONTINUE
747 110 CONTINUE
748 120 CONTINUE
749*
750 DO 130 ja = 1, na
751 IF( ilcplx ) THEN
752 sum( ja, 1 ) = -acoef*sums( ja, 1 ) +
753 $ bcoefr*sump( ja, 1 ) -
754 $ bcoefi*sump( ja, 2 )
755 sum( ja, 2 ) = -acoef*sums( ja, 2 ) +
756 $ bcoefr*sump( ja, 2 ) +
757 $ bcoefi*sump( ja, 1 )
758 ELSE
759 sum( ja, 1 ) = -acoef*sums( ja, 1 ) +
760 $ bcoefr*sump( ja, 1 )
761 END IF
762 130 CONTINUE
763*
764* T
765* Solve ( a A - b B ) y = SUM(,)
766* with scaling and perturbation of the denominator
767*
768 CALL slaln2( .true., na, nw, dmin, acoef, s( j, j ), lds,
769 $ bdiag( 1 ), bdiag( 2 ), sum, 2, bcoefr,
770 $ bcoefi, work( 2*n+j ), n, scale, temp,
771 $ iinfo )
772 IF( scale.LT.one ) THEN
773 DO 150 jw = 0, nw - 1
774 DO 140 jr = je, j - 1
775 work( ( jw+2 )*n+jr ) = scale*
776 $ work( ( jw+2 )*n+jr )
777 140 CONTINUE
778 150 CONTINUE
779 xmax = scale*xmax
780 END IF
781 xmax = max( xmax, temp )
782 160 CONTINUE
783*
784* Copy eigenvector to VL, back transforming if
785* HOWMNY='B'.
786*
787 ieig = ieig + 1
788 IF( ilback ) THEN
789 DO 170 jw = 0, nw - 1
790 CALL sgemv( 'N', n, n+1-je, one, vl( 1, je ), ldvl,
791 $ work( ( jw+2 )*n+je ), 1, zero,
792 $ work( ( jw+4 )*n+1 ), 1 )
793 170 CONTINUE
794 CALL slacpy( ' ', n, nw, work( 4*n+1 ), n, vl( 1, je ),
795 $ ldvl )
796 ibeg = 1
797 ELSE
798 CALL slacpy( ' ', n, nw, work( 2*n+1 ), n, vl( 1, ieig ),
799 $ ldvl )
800 ibeg = je
801 END IF
802*
803* Scale eigenvector
804*
805 xmax = zero
806 IF( ilcplx ) THEN
807 DO 180 j = ibeg, n
808 xmax = max( xmax, abs( vl( j, ieig ) )+
809 $ abs( vl( j, ieig+1 ) ) )
810 180 CONTINUE
811 ELSE
812 DO 190 j = ibeg, n
813 xmax = max( xmax, abs( vl( j, ieig ) ) )
814 190 CONTINUE
815 END IF
816*
817 IF( xmax.GT.safmin ) THEN
818 xscale = one / xmax
819*
820 DO 210 jw = 0, nw - 1
821 DO 200 jr = ibeg, n
822 vl( jr, ieig+jw ) = xscale*vl( jr, ieig+jw )
823 200 CONTINUE
824 210 CONTINUE
825 END IF
826 ieig = ieig + nw - 1
827*
828 220 CONTINUE
829 END IF
830*
831* Right eigenvectors
832*
833 IF( compr ) THEN
834 ieig = im + 1
835*
836* Main loop over eigenvalues
837*
838 ilcplx = .false.
839 DO 500 je = n, 1, -1
840*
841* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
842* (b) this would be the second of a complex pair.
843* Check for complex eigenvalue, so as to be sure of which
844* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
845* or SELECT(JE-1).
846* If this is a complex pair, the 2-by-2 diagonal block
847* corresponding to the eigenvalue is in rows/columns JE-1:JE
848*
849 IF( ilcplx ) THEN
850 ilcplx = .false.
851 GO TO 500
852 END IF
853 nw = 1
854 IF( je.GT.1 ) THEN
855 IF( s( je, je-1 ).NE.zero ) THEN
856 ilcplx = .true.
857 nw = 2
858 END IF
859 END IF
860 IF( ilall ) THEN
861 ilcomp = .true.
862 ELSE IF( ilcplx ) THEN
863 ilcomp = SELECT( je ) .OR. SELECT( je-1 )
864 ELSE
865 ilcomp = SELECT( je )
866 END IF
867 IF( .NOT.ilcomp )
868 $ GO TO 500
869*
870* Decide if (a) singular pencil, (b) real eigenvalue, or
871* (c) complex eigenvalue.
872*
873 IF( .NOT.ilcplx ) THEN
874 IF( abs( s( je, je ) ).LE.safmin .AND.
875 $ abs( p( je, je ) ).LE.safmin ) THEN
876*
877* Singular matrix pencil -- unit eigenvector
878*
879 ieig = ieig - 1
880 DO 230 jr = 1, n
881 vr( jr, ieig ) = zero
882 230 CONTINUE
883 vr( ieig, ieig ) = one
884 GO TO 500
885 END IF
886 END IF
887*
888* Clear vector
889*
890 DO 250 jw = 0, nw - 1
891 DO 240 jr = 1, n
892 work( ( jw+2 )*n+jr ) = zero
893 240 CONTINUE
894 250 CONTINUE
895*
896* Compute coefficients in ( a A - b B ) x = 0
897* a is ACOEF
898* b is BCOEFR + i*BCOEFI
899*
900 IF( .NOT.ilcplx ) THEN
901*
902* Real eigenvalue
903*
904 temp = one / max( abs( s( je, je ) )*ascale,
905 $ abs( p( je, je ) )*bscale, safmin )
906 salfar = ( temp*s( je, je ) )*ascale
907 sbeta = ( temp*p( je, je ) )*bscale
908 acoef = sbeta*ascale
909 bcoefr = salfar*bscale
910 bcoefi = zero
911*
912* Scale to avoid underflow
913*
914 scale = one
915 lsa = abs( sbeta ).GE.safmin .AND. abs( acoef ).LT.small
916 lsb = abs( salfar ).GE.safmin .AND. abs( bcoefr ).LT.
917 $ small
918 IF( lsa )
919 $ scale = ( small / abs( sbeta ) )*min( anorm, big )
920 IF( lsb )
921 $ scale = max( scale, ( small / abs( salfar ) )*
922 $ min( bnorm, big ) )
923 IF( lsa .OR. lsb ) THEN
924 scale = min( scale, one /
925 $ ( safmin*max( one, abs( acoef ),
926 $ abs( bcoefr ) ) ) )
927 IF( lsa ) THEN
928 acoef = ascale*( scale*sbeta )
929 ELSE
930 acoef = scale*acoef
931 END IF
932 IF( lsb ) THEN
933 bcoefr = bscale*( scale*salfar )
934 ELSE
935 bcoefr = scale*bcoefr
936 END IF
937 END IF
938 acoefa = abs( acoef )
939 bcoefa = abs( bcoefr )
940*
941* First component is 1
942*
943 work( 2*n+je ) = one
944 xmax = one
945*
946* Compute contribution from column JE of A and B to sum
947* (See "Further Details", above.)
948*
949 DO 260 jr = 1, je - 1
950 work( 2*n+jr ) = bcoefr*p( jr, je ) -
951 $ acoef*s( jr, je )
952 260 CONTINUE
953 ELSE
954*
955* Complex eigenvalue
956*
957 CALL slag2( s( je-1, je-1 ), lds, p( je-1, je-1 ), ldp,
958 $ safmin*safety, acoef, temp, bcoefr, temp2,
959 $ bcoefi )
960 IF( bcoefi.EQ.zero ) THEN
961 info = je - 1
962 RETURN
963 END IF
964*
965* Scale to avoid over/underflow
966*
967 acoefa = abs( acoef )
968 bcoefa = abs( bcoefr ) + abs( bcoefi )
969 scale = one
970 IF( acoefa*ulp.LT.safmin .AND. acoefa.GE.safmin )
971 $ scale = ( safmin / ulp ) / acoefa
972 IF( bcoefa*ulp.LT.safmin .AND. bcoefa.GE.safmin )
973 $ scale = max( scale, ( safmin / ulp ) / bcoefa )
974 IF( safmin*acoefa.GT.ascale )
975 $ scale = ascale / ( safmin*acoefa )
976 IF( safmin*bcoefa.GT.bscale )
977 $ scale = min( scale, bscale / ( safmin*bcoefa ) )
978 IF( scale.NE.one ) THEN
979 acoef = scale*acoef
980 acoefa = abs( acoef )
981 bcoefr = scale*bcoefr
982 bcoefi = scale*bcoefi
983 bcoefa = abs( bcoefr ) + abs( bcoefi )
984 END IF
985*
986* Compute first two components of eigenvector
987* and contribution to sums
988*
989 temp = acoef*s( je, je-1 )
990 temp2r = acoef*s( je, je ) - bcoefr*p( je, je )
991 temp2i = -bcoefi*p( je, je )
992 IF( abs( temp ).GE.abs( temp2r )+abs( temp2i ) ) THEN
993 work( 2*n+je ) = one
994 work( 3*n+je ) = zero
995 work( 2*n+je-1 ) = -temp2r / temp
996 work( 3*n+je-1 ) = -temp2i / temp
997 ELSE
998 work( 2*n+je-1 ) = one
999 work( 3*n+je-1 ) = zero
1000 temp = acoef*s( je-1, je )
1001 work( 2*n+je ) = ( bcoefr*p( je-1, je-1 )-acoef*
1002 $ s( je-1, je-1 ) ) / temp
1003 work( 3*n+je ) = bcoefi*p( je-1, je-1 ) / temp
1004 END IF
1005*
1006 xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),
1007 $ abs( work( 2*n+je-1 ) )+abs( work( 3*n+je-1 ) ) )
1008*
1009* Compute contribution from columns JE and JE-1
1010* of A and B to the sums.
1011*
1012 creala = acoef*work( 2*n+je-1 )
1013 cimaga = acoef*work( 3*n+je-1 )
1014 crealb = bcoefr*work( 2*n+je-1 ) -
1015 $ bcoefi*work( 3*n+je-1 )
1016 cimagb = bcoefi*work( 2*n+je-1 ) +
1017 $ bcoefr*work( 3*n+je-1 )
1018 cre2a = acoef*work( 2*n+je )
1019 cim2a = acoef*work( 3*n+je )
1020 cre2b = bcoefr*work( 2*n+je ) - bcoefi*work( 3*n+je )
1021 cim2b = bcoefi*work( 2*n+je ) + bcoefr*work( 3*n+je )
1022 DO 270 jr = 1, je - 2
1023 work( 2*n+jr ) = -creala*s( jr, je-1 ) +
1024 $ crealb*p( jr, je-1 ) -
1025 $ cre2a*s( jr, je ) + cre2b*p( jr, je )
1026 work( 3*n+jr ) = -cimaga*s( jr, je-1 ) +
1027 $ cimagb*p( jr, je-1 ) -
1028 $ cim2a*s( jr, je ) + cim2b*p( jr, je )
1029 270 CONTINUE
1030 END IF
1031*
1032 dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin )
1033*
1034* Columnwise triangular solve of (a A - b B) x = 0
1035*
1036 il2by2 = .false.
1037 DO 370 j = je - nw, 1, -1
1038*
1039* If a 2-by-2 block, is in position j-1:j, wait until
1040* next iteration to process it (when it will be j:j+1)
1041*
1042 IF( .NOT.il2by2 .AND. j.GT.1 ) THEN
1043 IF( s( j, j-1 ).NE.zero ) THEN
1044 il2by2 = .true.
1045 GO TO 370
1046 END IF
1047 END IF
1048 bdiag( 1 ) = p( j, j )
1049 IF( il2by2 ) THEN
1050 na = 2
1051 bdiag( 2 ) = p( j+1, j+1 )
1052 ELSE
1053 na = 1
1054 END IF
1055*
1056* Compute x(j) (and x(j+1), if 2-by-2 block)
1057*
1058 CALL slaln2( .false., na, nw, dmin, acoef, s( j, j ),
1059 $ lds, bdiag( 1 ), bdiag( 2 ), work( 2*n+j ),
1060 $ n, bcoefr, bcoefi, sum, 2, scale, temp,
1061 $ iinfo )
1062 IF( scale.LT.one ) THEN
1063*
1064 DO 290 jw = 0, nw - 1
1065 DO 280 jr = 1, je
1066 work( ( jw+2 )*n+jr ) = scale*
1067 $ work( ( jw+2 )*n+jr )
1068 280 CONTINUE
1069 290 CONTINUE
1070 END IF
1071 xmax = max( scale*xmax, temp )
1072*
1073 DO 310 jw = 1, nw
1074 DO 300 ja = 1, na
1075 work( ( jw+1 )*n+j+ja-1 ) = sum( ja, jw )
1076 300 CONTINUE
1077 310 CONTINUE
1078*
1079* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
1080*
1081 IF( j.GT.1 ) THEN
1082*
1083* Check whether scaling is necessary for sum.
1084*
1085 xscale = one / max( one, xmax )
1086 temp = acoefa*work( j ) + bcoefa*work( n+j )
1087 IF( il2by2 )
1088 $ temp = max( temp, acoefa*work( j+1 )+bcoefa*
1089 $ work( n+j+1 ) )
1090 temp = max( temp, acoefa, bcoefa )
1091 IF( temp.GT.bignum*xscale ) THEN
1092*
1093 DO 330 jw = 0, nw - 1
1094 DO 320 jr = 1, je
1095 work( ( jw+2 )*n+jr ) = xscale*
1096 $ work( ( jw+2 )*n+jr )
1097 320 CONTINUE
1098 330 CONTINUE
1099 xmax = xmax*xscale
1100 END IF
1101*
1102* Compute the contributions of the off-diagonals of
1103* column j (and j+1, if 2-by-2 block) of A and B to the
1104* sums.
1105*
1106*
1107 DO 360 ja = 1, na
1108 IF( ilcplx ) THEN
1109 creala = acoef*work( 2*n+j+ja-1 )
1110 cimaga = acoef*work( 3*n+j+ja-1 )
1111 crealb = bcoefr*work( 2*n+j+ja-1 ) -
1112 $ bcoefi*work( 3*n+j+ja-1 )
1113 cimagb = bcoefi*work( 2*n+j+ja-1 ) +
1114 $ bcoefr*work( 3*n+j+ja-1 )
1115 DO 340 jr = 1, j - 1
1116 work( 2*n+jr ) = work( 2*n+jr ) -
1117 $ creala*s( jr, j+ja-1 ) +
1118 $ crealb*p( jr, j+ja-1 )
1119 work( 3*n+jr ) = work( 3*n+jr ) -
1120 $ cimaga*s( jr, j+ja-1 ) +
1121 $ cimagb*p( jr, j+ja-1 )
1122 340 CONTINUE
1123 ELSE
1124 creala = acoef*work( 2*n+j+ja-1 )
1125 crealb = bcoefr*work( 2*n+j+ja-1 )
1126 DO 350 jr = 1, j - 1
1127 work( 2*n+jr ) = work( 2*n+jr ) -
1128 $ creala*s( jr, j+ja-1 ) +
1129 $ crealb*p( jr, j+ja-1 )
1130 350 CONTINUE
1131 END IF
1132 360 CONTINUE
1133 END IF
1134*
1135 il2by2 = .false.
1136 370 CONTINUE
1137*
1138* Copy eigenvector to VR, back transforming if
1139* HOWMNY='B'.
1140*
1141 ieig = ieig - nw
1142 IF( ilback ) THEN
1143*
1144 DO 410 jw = 0, nw - 1
1145 DO 380 jr = 1, n
1146 work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )*
1147 $ vr( jr, 1 )
1148 380 CONTINUE
1149*
1150* A series of compiler directives to defeat
1151* vectorization for the next loop
1152*
1153*
1154 DO 400 jc = 2, je
1155 DO 390 jr = 1, n
1156 work( ( jw+4 )*n+jr ) = work( ( jw+4 )*n+jr ) +
1157 $ work( ( jw+2 )*n+jc )*vr( jr, jc )
1158 390 CONTINUE
1159 400 CONTINUE
1160 410 CONTINUE
1161*
1162 DO 430 jw = 0, nw - 1
1163 DO 420 jr = 1, n
1164 vr( jr, ieig+jw ) = work( ( jw+4 )*n+jr )
1165 420 CONTINUE
1166 430 CONTINUE
1167*
1168 iend = n
1169 ELSE
1170 DO 450 jw = 0, nw - 1
1171 DO 440 jr = 1, n
1172 vr( jr, ieig+jw ) = work( ( jw+2 )*n+jr )
1173 440 CONTINUE
1174 450 CONTINUE
1175*
1176 iend = je
1177 END IF
1178*
1179* Scale eigenvector
1180*
1181 xmax = zero
1182 IF( ilcplx ) THEN
1183 DO 460 j = 1, iend
1184 xmax = max( xmax, abs( vr( j, ieig ) )+
1185 $ abs( vr( j, ieig+1 ) ) )
1186 460 CONTINUE
1187 ELSE
1188 DO 470 j = 1, iend
1189 xmax = max( xmax, abs( vr( j, ieig ) ) )
1190 470 CONTINUE
1191 END IF
1192*
1193 IF( xmax.GT.safmin ) THEN
1194 xscale = one / xmax
1195 DO 490 jw = 0, nw - 1
1196 DO 480 jr = 1, iend
1197 vr( jr, ieig+jw ) = xscale*vr( jr, ieig+jw )
1198 480 CONTINUE
1199 490 CONTINUE
1200 END IF
1201 500 CONTINUE
1202 END IF
1203*
1204 RETURN
1205*
1206* End of STGEVC
1207*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
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
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

◆ stgexc()

subroutine stgexc ( logical wantq,
logical wantz,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldb, * ) b,
integer ldb,
real, dimension( ldq, * ) q,
integer ldq,
real, dimension( ldz, * ) z,
integer ldz,
integer ifst,
integer ilst,
real, dimension( * ) work,
integer lwork,
integer info )

STGEXC

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

Purpose:
!>
!> STGEXC reorders the generalized real Schur decomposition of a real
!> matrix pair (A,B) using an orthogonal equivalence transformation
!>
!>                (A, B) = Q * (A, B) * Z**T,
!>
!> so that the diagonal block of (A, B) with row index IFST is moved
!> to row ILST.
!>
!> (A, B) must be in generalized real Schur canonical form (as returned
!> by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
!> diagonal blocks. B is upper triangular.
!>
!> Optionally, the matrices Q and Z of generalized Schur vectors are
!> updated.
!>
!>        Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T
!>        Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T
!>
!>
Parameters
[in]WANTQ
!>          WANTQ is LOGICAL
!>          .TRUE. : update the left transformation matrix Q;
!>          .FALSE.: do not update Q.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          .TRUE. : update the right transformation matrix Z;
!>          .FALSE.: do not update Z.
!>
[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 matrix A in generalized real Schur canonical
!>          form.
!>          On exit, the updated matrix A, again in generalized
!>          real Schur canonical form.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[in,out]B
!>          B is REAL array, dimension (LDB,N)
!>          On entry, the matrix B in generalized real Schur canonical
!>          form (A,B).
!>          On exit, the updated matrix B, again in generalized
!>          real Schur canonical form (A,B).
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
!>          On exit, the updated matrix Q.
!>          If WANTQ = .FALSE., Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= 1.
!>          If WANTQ = .TRUE., LDQ >= N.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ,N)
!>          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
!>          On exit, the updated matrix Z.
!>          If WANTZ = .FALSE., Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z. LDZ >= 1.
!>          If WANTZ = .TRUE., LDZ >= N.
!>
[in,out]IFST
!>          IFST is INTEGER
!>
[in,out]ILST
!>          ILST is INTEGER
!>          Specify the reordering of the diagonal blocks of (A, B).
!>          The block with row index IFST is moved to row ILST, by a
!>          sequence of swapping between adjacent blocks.
!>          On exit, if IFST pointed on entry to the second row of
!>          a 2-by-2 block, it is changed to point to the first row;
!>          ILST always points to the first row of the block in its
!>          final position (which may differ from its input value by
!>          +1 or -1). 1 <= IFST, ILST <= N.
!>
[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 when N <= 1, otherwise LWORK >= 4*N + 16.
!>
!>          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.
!>           =1:  The transformed matrix pair (A, B) would be too far
!>                from generalized Schur form; the problem is ill-
!>                conditioned. (A, B) may have been partially reordered,
!>                and ILST points to the first row of the current
!>                position of the block being moved.
!>
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; A Direct Method for Reordering Eigenvalues in the
!>      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
!>      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
!>      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
!>

Definition at line 218 of file stgexc.f.

220*
221* -- LAPACK computational routine --
222* -- LAPACK is a software package provided by Univ. of Tennessee, --
223* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
224*
225* .. Scalar Arguments ..
226 LOGICAL WANTQ, WANTZ
227 INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
228* ..
229* .. Array Arguments ..
230 REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
231 $ WORK( * ), Z( LDZ, * )
232* ..
233*
234* =====================================================================
235*
236* .. Parameters ..
237 REAL ZERO
238 parameter( zero = 0.0e+0 )
239* ..
240* .. Local Scalars ..
241 LOGICAL LQUERY
242 INTEGER HERE, LWMIN, NBF, NBL, NBNEXT
243* ..
244* .. External Subroutines ..
245 EXTERNAL stgex2, xerbla
246* ..
247* .. Intrinsic Functions ..
248 INTRINSIC max
249* ..
250* .. Executable Statements ..
251*
252* Decode and test input arguments.
253*
254 info = 0
255 lquery = ( lwork.EQ.-1 )
256 IF( n.LT.0 ) THEN
257 info = -3
258 ELSE IF( lda.LT.max( 1, n ) ) THEN
259 info = -5
260 ELSE IF( ldb.LT.max( 1, n ) ) THEN
261 info = -7
262 ELSE IF( ldq.LT.1 .OR. wantq .AND. ( ldq.LT.max( 1, n ) ) ) THEN
263 info = -9
264 ELSE IF( ldz.LT.1 .OR. wantz .AND. ( ldz.LT.max( 1, n ) ) ) THEN
265 info = -11
266 ELSE IF( ifst.LT.1 .OR. ifst.GT.n ) THEN
267 info = -12
268 ELSE IF( ilst.LT.1 .OR. ilst.GT.n ) THEN
269 info = -13
270 END IF
271*
272 IF( info.EQ.0 ) THEN
273 IF( n.LE.1 ) THEN
274 lwmin = 1
275 ELSE
276 lwmin = 4*n + 16
277 END IF
278 work(1) = lwmin
279*
280 IF (lwork.LT.lwmin .AND. .NOT.lquery) THEN
281 info = -15
282 END IF
283 END IF
284*
285 IF( info.NE.0 ) THEN
286 CALL xerbla( 'STGEXC', -info )
287 RETURN
288 ELSE IF( lquery ) THEN
289 RETURN
290 END IF
291*
292* Quick return if possible
293*
294 IF( n.LE.1 )
295 $ RETURN
296*
297* Determine the first row of the specified block and find out
298* if it is 1-by-1 or 2-by-2.
299*
300 IF( ifst.GT.1 ) THEN
301 IF( a( ifst, ifst-1 ).NE.zero )
302 $ ifst = ifst - 1
303 END IF
304 nbf = 1
305 IF( ifst.LT.n ) THEN
306 IF( a( ifst+1, ifst ).NE.zero )
307 $ nbf = 2
308 END IF
309*
310* Determine the first row of the final block
311* and find out if it is 1-by-1 or 2-by-2.
312*
313 IF( ilst.GT.1 ) THEN
314 IF( a( ilst, ilst-1 ).NE.zero )
315 $ ilst = ilst - 1
316 END IF
317 nbl = 1
318 IF( ilst.LT.n ) THEN
319 IF( a( ilst+1, ilst ).NE.zero )
320 $ nbl = 2
321 END IF
322 IF( ifst.EQ.ilst )
323 $ RETURN
324*
325 IF( ifst.LT.ilst ) THEN
326*
327* Update ILST.
328*
329 IF( nbf.EQ.2 .AND. nbl.EQ.1 )
330 $ ilst = ilst - 1
331 IF( nbf.EQ.1 .AND. nbl.EQ.2 )
332 $ ilst = ilst + 1
333*
334 here = ifst
335*
336 10 CONTINUE
337*
338* Swap with next one below.
339*
340 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
341*
342* Current block either 1-by-1 or 2-by-2.
343*
344 nbnext = 1
345 IF( here+nbf+1.LE.n ) THEN
346 IF( a( here+nbf+1, here+nbf ).NE.zero )
347 $ nbnext = 2
348 END IF
349 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
350 $ ldz, here, nbf, nbnext, work, lwork, info )
351 IF( info.NE.0 ) THEN
352 ilst = here
353 RETURN
354 END IF
355 here = here + nbnext
356*
357* Test if 2-by-2 block breaks into two 1-by-1 blocks.
358*
359 IF( nbf.EQ.2 ) THEN
360 IF( a( here+1, here ).EQ.zero )
361 $ nbf = 3
362 END IF
363*
364 ELSE
365*
366* Current block consists of two 1-by-1 blocks, each of which
367* must be swapped individually.
368*
369 nbnext = 1
370 IF( here+3.LE.n ) THEN
371 IF( a( here+3, here+2 ).NE.zero )
372 $ nbnext = 2
373 END IF
374 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
375 $ ldz, here+1, 1, nbnext, work, lwork, info )
376 IF( info.NE.0 ) THEN
377 ilst = here
378 RETURN
379 END IF
380 IF( nbnext.EQ.1 ) THEN
381*
382* Swap two 1-by-1 blocks.
383*
384 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
385 $ ldz, here, 1, 1, work, lwork, info )
386 IF( info.NE.0 ) THEN
387 ilst = here
388 RETURN
389 END IF
390 here = here + 1
391*
392 ELSE
393*
394* Recompute NBNEXT in case of 2-by-2 split.
395*
396 IF( a( here+2, here+1 ).EQ.zero )
397 $ nbnext = 1
398 IF( nbnext.EQ.2 ) THEN
399*
400* 2-by-2 block did not split.
401*
402 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
403 $ z, ldz, here, 1, nbnext, work, lwork,
404 $ info )
405 IF( info.NE.0 ) THEN
406 ilst = here
407 RETURN
408 END IF
409 here = here + 2
410 ELSE
411*
412* 2-by-2 block did split.
413*
414 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
415 $ z, ldz, here, 1, 1, work, lwork, info )
416 IF( info.NE.0 ) THEN
417 ilst = here
418 RETURN
419 END IF
420 here = here + 1
421 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
422 $ z, ldz, here, 1, 1, work, lwork, info )
423 IF( info.NE.0 ) THEN
424 ilst = here
425 RETURN
426 END IF
427 here = here + 1
428 END IF
429*
430 END IF
431 END IF
432 IF( here.LT.ilst )
433 $ GO TO 10
434 ELSE
435 here = ifst
436*
437 20 CONTINUE
438*
439* Swap with next one below.
440*
441 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
442*
443* Current block either 1-by-1 or 2-by-2.
444*
445 nbnext = 1
446 IF( here.GE.3 ) THEN
447 IF( a( here-1, here-2 ).NE.zero )
448 $ nbnext = 2
449 END IF
450 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
451 $ ldz, here-nbnext, nbnext, nbf, work, lwork,
452 $ info )
453 IF( info.NE.0 ) THEN
454 ilst = here
455 RETURN
456 END IF
457 here = here - nbnext
458*
459* Test if 2-by-2 block breaks into two 1-by-1 blocks.
460*
461 IF( nbf.EQ.2 ) THEN
462 IF( a( here+1, here ).EQ.zero )
463 $ nbf = 3
464 END IF
465*
466 ELSE
467*
468* Current block consists of two 1-by-1 blocks, each of which
469* must be swapped individually.
470*
471 nbnext = 1
472 IF( here.GE.3 ) THEN
473 IF( a( here-1, here-2 ).NE.zero )
474 $ nbnext = 2
475 END IF
476 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
477 $ ldz, here-nbnext, nbnext, 1, work, lwork,
478 $ info )
479 IF( info.NE.0 ) THEN
480 ilst = here
481 RETURN
482 END IF
483 IF( nbnext.EQ.1 ) THEN
484*
485* Swap two 1-by-1 blocks.
486*
487 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
488 $ ldz, here, nbnext, 1, work, lwork, info )
489 IF( info.NE.0 ) THEN
490 ilst = here
491 RETURN
492 END IF
493 here = here - 1
494 ELSE
495*
496* Recompute NBNEXT in case of 2-by-2 split.
497*
498 IF( a( here, here-1 ).EQ.zero )
499 $ nbnext = 1
500 IF( nbnext.EQ.2 ) THEN
501*
502* 2-by-2 block did not split.
503*
504 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
505 $ z, ldz, here-1, 2, 1, work, lwork, info )
506 IF( info.NE.0 ) THEN
507 ilst = here
508 RETURN
509 END IF
510 here = here - 2
511 ELSE
512*
513* 2-by-2 block did split.
514*
515 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
516 $ z, ldz, here, 1, 1, work, lwork, info )
517 IF( info.NE.0 ) THEN
518 ilst = here
519 RETURN
520 END IF
521 here = here - 1
522 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
523 $ z, ldz, here, 1, 1, work, lwork, info )
524 IF( info.NE.0 ) THEN
525 ilst = here
526 RETURN
527 END IF
528 here = here - 1
529 END IF
530 END IF
531 END IF
532 IF( here.GT.ilst )
533 $ GO TO 20
534 END IF
535 ilst = here
536 work( 1 ) = lwmin
537 RETURN
538*
539* End of STGEXC
540*
stgex2
subroutine stgex2(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, j1, n1, n2, work, lwork, info)
STGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equ...
Definition stgex2.f:221