LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
sgesvdx.f
Go to the documentation of this file.
1 *> \brief <b> SGESVDX computes the singular value decomposition (SVD) for GE matrices</b>
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SGESVDX + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgesvdx.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgesvdx.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgesvdx.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
22 * $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
23 * $ LWORK, IWORK, INFO )
24 *
25 *
26 * .. Scalar Arguments ..
27 * CHARACTER JOBU, JOBVT, RANGE
28 * INTEGER IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
29 * REAL VL, VU
30 * ..
31 * .. Array Arguments ..
32 * INTEGER IWORK( * )
33 * REAL A( LDA, * ), S( * ), U( LDU, * ),
34 * $ VT( LDVT, * ), WORK( * )
35 * ..
36 *
37 *
38 *> \par Purpose:
39 * =============
40 *>
41 *> \verbatim
42 *>
43 *> SGESVDX computes the singular value decomposition (SVD) of a real
44 *> M-by-N matrix A, optionally computing the left and/or right singular
45 *> vectors. The SVD is written
46 *>
47 *> A = U * SIGMA * transpose(V)
48 *>
49 *> where SIGMA is an M-by-N matrix which is zero except for its
50 *> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
51 *> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
52 *> are the singular values of A; they are real and non-negative, and
53 *> are returned in descending order. The first min(m,n) columns of
54 *> U and V are the left and right singular vectors of A.
55 *>
56 *> SGESVDX uses an eigenvalue problem for obtaining the SVD, which
57 *> allows for the computation of a subset of singular values and
58 *> vectors. See SBDSVDX for details.
59 *>
60 *> Note that the routine returns V**T, not V.
61 *> \endverbatim
62 *
63 * Arguments:
64 * ==========
65 *
66 *> \param[in] JOBU
67 *> \verbatim
68 *> JOBU is CHARACTER*1
69 *> Specifies options for computing all or part of the matrix U:
70 *> = 'V': the first min(m,n) columns of U (the left singular
71 *> vectors) or as specified by RANGE are returned in
72 *> the array U;
73 *> = 'N': no columns of U (no left singular vectors) are
74 *> computed.
75 *> \endverbatim
76 *>
77 *> \param[in] JOBVT
78 *> \verbatim
79 *> JOBVT is CHARACTER*1
80 *> Specifies options for computing all or part of the matrix
81 *> V**T:
82 *> = 'V': the first min(m,n) rows of V**T (the right singular
83 *> vectors) or as specified by RANGE are returned in
84 *> the array VT;
85 *> = 'N': no rows of V**T (no right singular vectors) are
86 *> computed.
87 *> \endverbatim
88 *>
89 *> \param[in] RANGE
90 *> \verbatim
91 *> RANGE is CHARACTER*1
92 *> = 'A': all singular values will be found.
93 *> = 'V': all singular values in the half-open interval (VL,VU]
94 *> will be found.
95 *> = 'I': the IL-th through IU-th singular values will be found.
96 *> \endverbatim
97 *>
98 *> \param[in] M
99 *> \verbatim
100 *> M is INTEGER
101 *> The number of rows of the input matrix A. M >= 0.
102 *> \endverbatim
103 *>
104 *> \param[in] N
105 *> \verbatim
106 *> N is INTEGER
107 *> The number of columns of the input matrix A. N >= 0.
108 *> \endverbatim
109 *>
110 *> \param[in,out] A
111 *> \verbatim
112 *> A is REAL array, dimension (LDA,N)
113 *> On entry, the M-by-N matrix A.
114 *> On exit, the contents of A are destroyed.
115 *> \endverbatim
116 *>
117 *> \param[in] LDA
118 *> \verbatim
119 *> LDA is INTEGER
120 *> The leading dimension of the array A. LDA >= max(1,M).
121 *> \endverbatim
122 *>
123 *> \param[in] VL
124 *> \verbatim
125 *> VL is REAL
126 *> If RANGE='V', the lower bound of the interval to
127 *> be searched for singular values. VU > VL.
128 *> Not referenced if RANGE = 'A' or 'I'.
129 *> \endverbatim
130 *>
131 *> \param[in] VU
132 *> \verbatim
133 *> VU is REAL
134 *> If RANGE='V', the upper bound of the interval to
135 *> be searched for singular values. VU > VL.
136 *> Not referenced if RANGE = 'A' or 'I'.
137 *> \endverbatim
138 *>
139 *> \param[in] IL
140 *> \verbatim
141 *> IL is INTEGER
142 *> If RANGE='I', the index of the
143 *> smallest singular value to be returned.
144 *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
145 *> Not referenced if RANGE = 'A' or 'V'.
146 *> \endverbatim
147 *>
148 *> \param[in] IU
149 *> \verbatim
150 *> IU is INTEGER
151 *> If RANGE='I', the index of the
152 *> largest singular value to be returned.
153 *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
154 *> Not referenced if RANGE = 'A' or 'V'.
155 *> \endverbatim
156 *>
157 *> \param[out] NS
158 *> \verbatim
159 *> NS is INTEGER
160 *> The total number of singular values found,
161 *> 0 <= NS <= min(M,N).
162 *> If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1.
163 *> \endverbatim
164 *>
165 *> \param[out] S
166 *> \verbatim
167 *> S is REAL array, dimension (min(M,N))
168 *> The singular values of A, sorted so that S(i) >= S(i+1).
169 *> \endverbatim
170 *>
171 *> \param[out] U
172 *> \verbatim
173 *> U is REAL array, dimension (LDU,UCOL)
174 *> If JOBU = 'V', U contains columns of U (the left singular
175 *> vectors, stored columnwise) as specified by RANGE; if
176 *> JOBU = 'N', U is not referenced.
177 *> Note: The user must ensure that UCOL >= NS; if RANGE = 'V',
178 *> the exact value of NS is not known in advance and an upper
179 *> bound must be used.
180 *> \endverbatim
181 *>
182 *> \param[in] LDU
183 *> \verbatim
184 *> LDU is INTEGER
185 *> The leading dimension of the array U. LDU >= 1; if
186 *> JOBU = 'V', LDU >= M.
187 *> \endverbatim
188 *>
189 *> \param[out] VT
190 *> \verbatim
191 *> VT is REAL array, dimension (LDVT,N)
192 *> If JOBVT = 'V', VT contains the rows of V**T (the right singular
193 *> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N',
194 *> VT is not referenced.
195 *> Note: The user must ensure that LDVT >= NS; if RANGE = 'V',
196 *> the exact value of NS is not known in advance and an upper
197 *> bound must be used.
198 *> \endverbatim
199 *>
200 *> \param[in] LDVT
201 *> \verbatim
202 *> LDVT is INTEGER
203 *> The leading dimension of the array VT. LDVT >= 1; if
204 *> JOBVT = 'V', LDVT >= NS (see above).
205 *> \endverbatim
206 *>
207 *> \param[out] WORK
208 *> \verbatim
209 *> WORK is REAL array, dimension (MAX(1,LWORK))
210 *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
211 *> \endverbatim
212 *>
213 *> \param[in] LWORK
214 *> \verbatim
215 *> LWORK is INTEGER
216 *> The dimension of the array WORK.
217 *> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see
218 *> comments inside the code):
219 *> - PATH 1 (M much larger than N)
220 *> - PATH 1t (N much larger than M)
221 *> LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths.
222 *> For good performance, LWORK should generally be larger.
223 *>
224 *> If LWORK = -1, then a workspace query is assumed; the routine
225 *> only calculates the optimal size of the WORK array, returns
226 *> this value as the first entry of the WORK array, and no error
227 *> message related to LWORK is issued by XERBLA.
228 *> \endverbatim
229 *>
230 *> \param[out] IWORK
231 *> \verbatim
232 *> IWORK is INTEGER array, dimension (12*MIN(M,N))
233 *> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0,
234 *> then IWORK contains the indices of the eigenvectors that failed
235 *> to converge in SBDSVDX/SSTEVX.
236 *> \endverbatim
237 *>
238 *> \param[out] INFO
239 *> \verbatim
240 *> INFO is INTEGER
241 *> = 0: successful exit
242 *> < 0: if INFO = -i, the i-th argument had an illegal value
243 *> > 0: if INFO = i, then i eigenvectors failed to converge
244 *> in SBDSVDX/SSTEVX.
245 *> if INFO = N*2 + 1, an internal error occurred in
246 *> SBDSVDX
247 *> \endverbatim
248 *
249 * Authors:
250 * ========
251 *
252 *> \author Univ. of Tennessee
253 *> \author Univ. of California Berkeley
254 *> \author Univ. of Colorado Denver
255 *> \author NAG Ltd.
256 *
257 *> \date June 2016
258 *
259 *> \ingroup realGEsing
260 *
261 * =====================================================================
262  SUBROUTINE sgesvdx( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
263  $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
264  $ LWORK, IWORK, INFO )
265 *
266 * -- LAPACK driver routine (version 3.7.0) --
267 * -- LAPACK is a software package provided by Univ. of Tennessee, --
268 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
269 * June 2016
270 *
271 * .. Scalar Arguments ..
272  CHARACTER JOBU, JOBVT, RANGE
273  INTEGER IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
274  REAL VL, VU
275 * ..
276 * .. Array Arguments ..
277  INTEGER IWORK( * )
278  REAL A( lda, * ), S( * ), U( ldu, * ),
279  $ vt( ldvt, * ), work( * )
280 * ..
281 *
282 * =====================================================================
283 *
284 * .. Parameters ..
285  REAL ZERO, ONE
286  parameter( zero = 0.0e0, one = 1.0e0 )
287 * ..
288 * .. Local Scalars ..
289  CHARACTER JOBZ, RNGTGK
290  LOGICAL ALLS, INDS, LQUERY, VALS, WANTU, WANTVT
291  INTEGER I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL,
292  $ itau, itaup, itauq, itemp, itgkz, iutgk,
293  $ j, maxwrk, minmn, minwrk, mnthr
294  REAL ABSTOL, ANRM, BIGNUM, EPS, SMLNUM
295 * ..
296 * .. Local Arrays ..
297  REAL DUM( 1 )
298 * ..
299 * .. External Subroutines ..
300  EXTERNAL sbdsvdx, sgebrd, sgelqf, sgeqrf, slacpy,
301  $ slascl, slaset, sormbr, sormlq, sormqr,
302  $ xerbla
303 * ..
304 * .. External Functions ..
305  LOGICAL LSAME
306  INTEGER ILAENV
307  REAL SLAMCH, SLANGE
308  EXTERNAL lsame, ilaenv, slamch, slange
309 * ..
310 * .. Intrinsic Functions ..
311  INTRINSIC max, min, sqrt
312 * ..
313 * .. Executable Statements ..
314 *
315 * Test the input arguments.
316 *
317  ns = 0
318  info = 0
319  abstol = 2*slamch('S')
320  lquery = ( lwork.EQ.-1 )
321  minmn = min( m, n )
322 
323  wantu = lsame( jobu, 'V' )
324  wantvt = lsame( jobvt, 'V' )
325  IF( wantu .OR. wantvt ) THEN
326  jobz = 'V'
327  ELSE
328  jobz = 'N'
329  END IF
330  alls = lsame( range, 'A' )
331  vals = lsame( range, 'V' )
332  inds = lsame( range, 'I' )
333 *
334  info = 0
335  IF( .NOT.lsame( jobu, 'V' ) .AND.
336  $ .NOT.lsame( jobu, 'N' ) ) THEN
337  info = -1
338  ELSE IF( .NOT.lsame( jobvt, 'V' ) .AND.
339  $ .NOT.lsame( jobvt, 'N' ) ) THEN
340  info = -2
341  ELSE IF( .NOT.( alls .OR. vals .OR. inds ) ) THEN
342  info = -3
343  ELSE IF( m.LT.0 ) THEN
344  info = -4
345  ELSE IF( n.LT.0 ) THEN
346  info = -5
347  ELSE IF( m.GT.lda ) THEN
348  info = -7
349  ELSE IF( minmn.GT.0 ) THEN
350  IF( vals ) THEN
351  IF( vl.LT.zero ) THEN
352  info = -8
353  ELSE IF( vu.LE.vl ) THEN
354  info = -9
355  END IF
356  ELSE IF( inds ) THEN
357  IF( il.LT.1 .OR. il.GT.max( 1, minmn ) ) THEN
358  info = -10
359  ELSE IF( iu.LT.min( minmn, il ) .OR. iu.GT.minmn ) THEN
360  info = -11
361  END IF
362  END IF
363  IF( info.EQ.0 ) THEN
364  IF( wantu .AND. ldu.LT.m ) THEN
365  info = -15
366  ELSE IF( wantvt ) THEN
367  IF( inds ) THEN
368  IF( ldvt.LT.iu-il+1 ) THEN
369  info = -17
370  END IF
371  ELSE IF( ldvt.LT.minmn ) THEN
372  info = -17
373  END IF
374  END IF
375  END IF
376  END IF
377 *
378 * Compute workspace
379 * (Note: Comments in the code beginning "Workspace:" describe the
380 * minimal amount of workspace needed at that point in the code,
381 * as well as the preferred amount for good performance.
382 * NB refers to the optimal block size for the immediately
383 * following subroutine, as returned by ILAENV.)
384 *
385  IF( info.EQ.0 ) THEN
386  minwrk = 1
387  maxwrk = 1
388  IF( minmn.GT.0 ) THEN
389  IF( m.GE.n ) THEN
390  mnthr = ilaenv( 6, 'SGESVD', jobu // jobvt, m, n, 0, 0 )
391  IF( m.GE.mnthr ) THEN
392 *
393 * Path 1 (M much larger than N)
394 *
395  maxwrk = n +
396  $ n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 )
397  maxwrk = max( maxwrk, n*(n+5) + 2*n*
398  $ ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) )
399  IF (wantu) THEN
400  maxwrk = max(maxwrk,n*(n*3+6)+n*
401  $ ilaenv( 1, 'SORMQR', ' ', n, n, -1, -1 ) )
402  END IF
403  IF (wantvt) THEN
404  maxwrk = max(maxwrk,n*(n*3+6)+n*
405  $ ilaenv( 1, 'SORMLQ', ' ', n, n, -1, -1 ) )
406  END IF
407  minwrk = n*(n*3+20)
408  ELSE
409 *
410 * Path 2 (M at least N, but not much larger)
411 *
412  maxwrk = 4*n + ( m+n )*
413  $ ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 )
414  IF (wantu) THEN
415  maxwrk = max(maxwrk,n*(n*2+5)+n*
416  $ ilaenv( 1, 'SORMQR', ' ', n, n, -1, -1 ) )
417  END IF
418  IF (wantvt) THEN
419  maxwrk = max(maxwrk,n*(n*2+5)+n*
420  $ ilaenv( 1, 'SORMLQ', ' ', n, n, -1, -1 ) )
421  END IF
422  minwrk = max(n*(n*2+19),4*n+m)
423  END IF
424  ELSE
425  mnthr = ilaenv( 6, 'SGESVD', jobu // jobvt, m, n, 0, 0 )
426  IF( n.GE.mnthr ) THEN
427 *
428 * Path 1t (N much larger than M)
429 *
430  maxwrk = m +
431  $ m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 )
432  maxwrk = max( maxwrk, m*(m+5) + 2*m*
433  $ ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) )
434  IF (wantu) THEN
435  maxwrk = max(maxwrk,m*(m*3+6)+m*
436  $ ilaenv( 1, 'SORMQR', ' ', m, m, -1, -1 ) )
437  END IF
438  IF (wantvt) THEN
439  maxwrk = max(maxwrk,m*(m*3+6)+m*
440  $ ilaenv( 1, 'SORMLQ', ' ', m, m, -1, -1 ) )
441  END IF
442  minwrk = m*(m*3+20)
443  ELSE
444 *
445 * Path 2t (N at least M, but not much larger)
446 *
447  maxwrk = 4*m + ( m+n )*
448  $ ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 )
449  IF (wantu) THEN
450  maxwrk = max(maxwrk,m*(m*2+5)+m*
451  $ ilaenv( 1, 'SORMQR', ' ', m, m, -1, -1 ) )
452  END IF
453  IF (wantvt) THEN
454  maxwrk = max(maxwrk,m*(m*2+5)+m*
455  $ ilaenv( 1, 'SORMLQ', ' ', m, m, -1, -1 ) )
456  END IF
457  minwrk = max(m*(m*2+19),4*m+n)
458  END IF
459  END IF
460  END IF
461  maxwrk = max( maxwrk, minwrk )
462  work( 1 ) = REAL( maxwrk )
463 *
464  IF( lwork.LT.minwrk .AND. .NOT.lquery ) THEN
465  info = -19
466  END IF
467  END IF
468 *
469  IF( info.NE.0 ) THEN
470  CALL xerbla( 'SGESVDX', -info )
471  RETURN
472  ELSE IF( lquery ) THEN
473  RETURN
474  END IF
475 *
476 * Quick return if possible
477 *
478  IF( m.EQ.0 .OR. n.EQ.0 ) THEN
479  RETURN
480  END IF
481 *
482 * Set singular values indices accord to RANGE.
483 *
484  IF( alls ) THEN
485  rngtgk = 'I'
486  iltgk = 1
487  iutgk = min( m, n )
488  ELSE IF( inds ) THEN
489  rngtgk = 'I'
490  iltgk = il
491  iutgk = iu
492  ELSE
493  rngtgk = 'V'
494  iltgk = 0
495  iutgk = 0
496  END IF
497 *
498 * Get machine constants
499 *
500  eps = slamch( 'P' )
501  smlnum = sqrt( slamch( 'S' ) ) / eps
502  bignum = one / smlnum
503 *
504 * Scale A if max element outside range [SMLNUM,BIGNUM]
505 *
506  anrm = slange( 'M', m, n, a, lda, dum )
507  iscl = 0
508  IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
509  iscl = 1
510  CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
511  ELSE IF( anrm.GT.bignum ) THEN
512  iscl = 1
513  CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
514  END IF
515 *
516  IF( m.GE.n ) THEN
517 *
518 * A has at least as many rows as columns. If A has sufficiently
519 * more rows than columns, first reduce A using the QR
520 * decomposition.
521 *
522  IF( m.GE.mnthr ) THEN
523 *
524 * Path 1 (M much larger than N):
525 * A = Q * R = Q * ( QB * B * PB**T )
526 * = Q * ( QB * ( UB * S * VB**T ) * PB**T )
527 * U = Q * QB * UB; V**T = VB**T * PB**T
528 *
529 * Compute A=Q*R
530 * (Workspace: need 2*N, prefer N+N*NB)
531 *
532  itau = 1
533  itemp = itau + n
534  CALL sgeqrf( m, n, a, lda, work( itau ), work( itemp ),
535  $ lwork-itemp+1, info )
536 *
537 * Copy R into WORK and bidiagonalize it:
538 * (Workspace: need N*N+5*N, prefer N*N+4*N+2*N*NB)
539 *
540  iqrf = itemp
541  id = iqrf + n*n
542  ie = id + n
543  itauq = ie + n
544  itaup = itauq + n
545  itemp = itaup + n
546  CALL slacpy( 'U', n, n, a, lda, work( iqrf ), n )
547  CALL slaset( 'L', n-1, n-1, zero, zero, work( iqrf+1 ), n )
548  CALL sgebrd( n, n, work( iqrf ), n, work( id ), work( ie ),
549  $ work( itauq ), work( itaup ), work( itemp ),
550  $ lwork-itemp+1, info )
551 *
552 * Solve eigenvalue problem TGK*Z=Z*S.
553 * (Workspace: need 14*N + 2*N*(N+1))
554 *
555  itgkz = itemp
556  itemp = itgkz + n*(n*2+1)
557  CALL sbdsvdx( 'U', jobz, rngtgk, n, work( id ), work( ie ),
558  $ vl, vu, iltgk, iutgk, ns, s, work( itgkz ),
559  $ n*2, work( itemp ), iwork, info)
560 *
561 * If needed, compute left singular vectors.
562 *
563  IF( wantu ) THEN
564  j = itgkz
565  DO i = 1, ns
566  CALL scopy( n, work( j ), 1, u( 1,i ), 1 )
567  j = j + n*2
568  END DO
569  CALL slaset( 'A', m-n, ns, zero, zero, u( n+1,1 ), ldu )
570 *
571 * Call SORMBR to compute QB*UB.
572 * (Workspace in WORK( ITEMP ): need N, prefer N*NB)
573 *
574  CALL sormbr( 'Q', 'L', 'N', n, ns, n, work( iqrf ), n,
575  $ work( itauq ), u, ldu, work( itemp ),
576  $ lwork-itemp+1, info )
577 *
578 * Call SORMQR to compute Q*(QB*UB).
579 * (Workspace in WORK( ITEMP ): need N, prefer N*NB)
580 *
581  CALL sormqr( 'L', 'N', m, ns, n, a, lda,
582  $ work( itau ), u, ldu, work( itemp ),
583  $ lwork-itemp+1, info )
584  END IF
585 *
586 * If needed, compute right singular vectors.
587 *
588  IF( wantvt) THEN
589  j = itgkz + n
590  DO i = 1, ns
591  CALL scopy( n, work( j ), 1, vt( i,1 ), ldvt )
592  j = j + n*2
593  END DO
594 *
595 * Call SORMBR to compute VB**T * PB**T
596 * (Workspace in WORK( ITEMP ): need N, prefer N*NB)
597 *
598  CALL sormbr( 'P', 'R', 'T', ns, n, n, work( iqrf ), n,
599  $ work( itaup ), vt, ldvt, work( itemp ),
600  $ lwork-itemp+1, info )
601  END IF
602  ELSE
603 *
604 * Path 2 (M at least N, but not much larger)
605 * Reduce A to bidiagonal form without QR decomposition
606 * A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
607 * U = QB * UB; V**T = VB**T * PB**T
608 *
609 * Bidiagonalize A
610 * (Workspace: need 4*N+M, prefer 4*N+(M+N)*NB)
611 *
612  id = 1
613  ie = id + n
614  itauq = ie + n
615  itaup = itauq + n
616  itemp = itaup + n
617  CALL sgebrd( m, n, a, lda, work( id ), work( ie ),
618  $ work( itauq ), work( itaup ), work( itemp ),
619  $ lwork-itemp+1, info )
620 *
621 * Solve eigenvalue problem TGK*Z=Z*S.
622 * (Workspace: need 14*N + 2*N*(N+1))
623 *
624  itgkz = itemp
625  itemp = itgkz + n*(n*2+1)
626  CALL sbdsvdx( 'U', jobz, rngtgk, n, work( id ), work( ie ),
627  $ vl, vu, iltgk, iutgk, ns, s, work( itgkz ),
628  $ n*2, work( itemp ), iwork, info)
629 *
630 * If needed, compute left singular vectors.
631 *
632  IF( wantu ) THEN
633  j = itgkz
634  DO i = 1, ns
635  CALL scopy( n, work( j ), 1, u( 1,i ), 1 )
636  j = j + n*2
637  END DO
638  CALL slaset( 'A', m-n, ns, zero, zero, u( n+1,1 ), ldu )
639 *
640 * Call SORMBR to compute QB*UB.
641 * (Workspace in WORK( ITEMP ): need N, prefer N*NB)
642 *
643  CALL sormbr( 'Q', 'L', 'N', m, ns, n, a, lda,
644  $ work( itauq ), u, ldu, work( itemp ),
645  $ lwork-itemp+1, ierr )
646  END IF
647 *
648 * If needed, compute right singular vectors.
649 *
650  IF( wantvt) THEN
651  j = itgkz + n
652  DO i = 1, ns
653  CALL scopy( n, work( j ), 1, vt( i,1 ), ldvt )
654  j = j + n*2
655  END DO
656 *
657 * Call SORMBR to compute VB**T * PB**T
658 * (Workspace in WORK( ITEMP ): need N, prefer N*NB)
659 *
660  CALL sormbr( 'P', 'R', 'T', ns, n, n, a, lda,
661  $ work( itaup ), vt, ldvt, work( itemp ),
662  $ lwork-itemp+1, ierr )
663  END IF
664  END IF
665  ELSE
666 *
667 * A has more columns than rows. If A has sufficiently more
668 * columns than rows, first reduce A using the LQ decomposition.
669 *
670  IF( n.GE.mnthr ) THEN
671 *
672 * Path 1t (N much larger than M):
673 * A = L * Q = ( QB * B * PB**T ) * Q
674 * = ( QB * ( UB * S * VB**T ) * PB**T ) * Q
675 * U = QB * UB ; V**T = VB**T * PB**T * Q
676 *
677 * Compute A=L*Q
678 * (Workspace: need 2*M, prefer M+M*NB)
679 *
680  itau = 1
681  itemp = itau + m
682  CALL sgelqf( m, n, a, lda, work( itau ), work( itemp ),
683  $ lwork-itemp+1, info )
684 
685 * Copy L into WORK and bidiagonalize it:
686 * (Workspace in WORK( ITEMP ): need M*M+5*N, prefer M*M+4*M+2*M*NB)
687 *
688  ilqf = itemp
689  id = ilqf + m*m
690  ie = id + m
691  itauq = ie + m
692  itaup = itauq + m
693  itemp = itaup + m
694  CALL slacpy( 'L', m, m, a, lda, work( ilqf ), m )
695  CALL slaset( 'U', m-1, m-1, zero, zero, work( ilqf+m ), m )
696  CALL sgebrd( m, m, work( ilqf ), m, work( id ), work( ie ),
697  $ work( itauq ), work( itaup ), work( itemp ),
698  $ lwork-itemp+1, info )
699 *
700 * Solve eigenvalue problem TGK*Z=Z*S.
701 * (Workspace: need 2*M*M+14*M)
702 *
703  itgkz = itemp
704  itemp = itgkz + m*(m*2+1)
705  CALL sbdsvdx( 'U', jobz, rngtgk, m, work( id ), work( ie ),
706  $ vl, vu, iltgk, iutgk, ns, s, work( itgkz ),
707  $ m*2, work( itemp ), iwork, info)
708 *
709 * If needed, compute left singular vectors.
710 *
711  IF( wantu ) THEN
712  j = itgkz
713  DO i = 1, ns
714  CALL scopy( m, work( j ), 1, u( 1,i ), 1 )
715  j = j + m*2
716  END DO
717 *
718 * Call SORMBR to compute QB*UB.
719 * (Workspace in WORK( ITEMP ): need M, prefer M*NB)
720 *
721  CALL sormbr( 'Q', 'L', 'N', m, ns, m, work( ilqf ), m,
722  $ work( itauq ), u, ldu, work( itemp ),
723  $ lwork-itemp+1, info )
724  END IF
725 *
726 * If needed, compute right singular vectors.
727 *
728  IF( wantvt) THEN
729  j = itgkz + m
730  DO i = 1, ns
731  CALL scopy( m, work( j ), 1, vt( i,1 ), ldvt )
732  j = j + m*2
733  END DO
734  CALL slaset( 'A', ns, n-m, zero, zero, vt( 1,m+1 ), ldvt)
735 *
736 * Call SORMBR to compute (VB**T)*(PB**T)
737 * (Workspace in WORK( ITEMP ): need M, prefer M*NB)
738 *
739  CALL sormbr( 'P', 'R', 'T', ns, m, m, work( ilqf ), m,
740  $ work( itaup ), vt, ldvt, work( itemp ),
741  $ lwork-itemp+1, info )
742 *
743 * Call SORMLQ to compute ((VB**T)*(PB**T))*Q.
744 * (Workspace in WORK( ITEMP ): need M, prefer M*NB)
745 *
746  CALL sormlq( 'R', 'N', ns, n, m, a, lda,
747  $ work( itau ), vt, ldvt, work( itemp ),
748  $ lwork-itemp+1, info )
749  END IF
750  ELSE
751 *
752 * Path 2t (N greater than M, but not much larger)
753 * Reduce to bidiagonal form without LQ decomposition
754 * A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
755 * U = QB * UB; V**T = VB**T * PB**T
756 *
757 * Bidiagonalize A
758 * (Workspace: need 4*M+N, prefer 4*M+(M+N)*NB)
759 *
760  id = 1
761  ie = id + m
762  itauq = ie + m
763  itaup = itauq + m
764  itemp = itaup + m
765  CALL sgebrd( m, n, a, lda, work( id ), work( ie ),
766  $ work( itauq ), work( itaup ), work( itemp ),
767  $ lwork-itemp+1, info )
768 *
769 * Solve eigenvalue problem TGK*Z=Z*S.
770 * (Workspace: need 2*M*M+14*M)
771 *
772  itgkz = itemp
773  itemp = itgkz + m*(m*2+1)
774  CALL sbdsvdx( 'L', jobz, rngtgk, m, work( id ), work( ie ),
775  $ vl, vu, iltgk, iutgk, ns, s, work( itgkz ),
776  $ m*2, work( itemp ), iwork, info)
777 *
778 * If needed, compute left singular vectors.
779 *
780  IF( wantu ) THEN
781  j = itgkz
782  DO i = 1, ns
783  CALL scopy( m, work( j ), 1, u( 1,i ), 1 )
784  j = j + m*2
785  END DO
786 *
787 * Call SORMBR to compute QB*UB.
788 * (Workspace in WORK( ITEMP ): need M, prefer M*NB)
789 *
790  CALL sormbr( 'Q', 'L', 'N', m, ns, n, a, lda,
791  $ work( itauq ), u, ldu, work( itemp ),
792  $ lwork-itemp+1, info )
793  END IF
794 *
795 * If needed, compute right singular vectors.
796 *
797  IF( wantvt) THEN
798  j = itgkz + m
799  DO i = 1, ns
800  CALL scopy( m, work( j ), 1, vt( i,1 ), ldvt )
801  j = j + m*2
802  END DO
803  CALL slaset( 'A', ns, n-m, zero, zero, vt( 1,m+1 ), ldvt)
804 *
805 * Call SORMBR to compute VB**T * PB**T
806 * (Workspace in WORK( ITEMP ): need M, prefer M*NB)
807 *
808  CALL sormbr( 'P', 'R', 'T', ns, n, m, a, lda,
809  $ work( itaup ), vt, ldvt, work( itemp ),
810  $ lwork-itemp+1, info )
811  END IF
812  END IF
813  END IF
814 *
815 * Undo scaling if necessary
816 *
817  IF( iscl.EQ.1 ) THEN
818  IF( anrm.GT.bignum )
819  $ CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1,
820  $ s, minmn, info )
821  IF( anrm.LT.smlnum )
822  $ CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1,
823  $ s, minmn, info )
824  END IF
825 *
826 * Return optimal workspace in WORK(1)
827 *
828  work( 1 ) = REAL( maxwrk )
829 *
830  RETURN
831 *
832 * End of SGESVDX
833 *
834  END
sgebrd
subroutine sgebrd(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO)
SGEBRD
Definition: sgebrd.f:207
sormlq
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ
Definition: sormlq.f:170
sormqr
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
Definition: sormqr.f:170
sgesvdx
subroutine sgesvdx(JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IL, IU, NS, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
SGESVDX computes the singular value decomposition (SVD) for GE matrices
Definition: sgesvdx.f:265
sormbr
subroutine sormbr(VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMBR
Definition: sormbr.f:198
sgeqrf
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
Definition: sgeqrf.f:138
sbdsvdx
subroutine sbdsvdx(UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, NS, S, Z, LDZ, WORK, IWORK, INFO)
SBDSVDX
Definition: sbdsvdx.f:228
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
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:112
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:145
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:105
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:84
sgelqf
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
Definition: sgelqf.f:137