```001:       SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
002:      \$                   WORK, IWORK, INFO )
003: *
004: *  -- LAPACK routine (version 3.2) --
005: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       CHARACTER          COMPQ, UPLO
010:       INTEGER            INFO, LDU, LDVT, N
011: *     ..
012: *     .. Array Arguments ..
013:       INTEGER            IQ( * ), IWORK( * )
014:       DOUBLE PRECISION   D( * ), E( * ), Q( * ), U( LDU, * ),
015:      \$                   VT( LDVT, * ), WORK( * )
016: *     ..
017: *
018: *  Purpose
019: *  =======
020: *
021: *  DBDSDC computes the singular value decomposition (SVD) of a real
022: *  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
023: *  using a divide and conquer method, where S is a diagonal matrix
024: *  with non-negative diagonal elements (the singular values of B), and
025: *  U and VT are orthogonal matrices of left and right singular vectors,
026: *  respectively. DBDSDC can be used to compute all singular values,
027: *  and optionally, singular vectors or singular vectors in compact form.
028: *
029: *  This code makes very mild assumptions about floating point
030: *  arithmetic. It will work on machines with a guard digit in
031: *  add/subtract, or on those binary machines without guard digits
032: *  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
033: *  It could conceivably fail on hexadecimal or decimal machines
034: *  without guard digits, but we know of none.  See DLASD3 for details.
035: *
036: *  The code currently calls DLASDQ if singular values only are desired.
037: *  However, it can be slightly modified to compute singular values
038: *  using the divide and conquer method.
039: *
040: *  Arguments
041: *  =========
042: *
043: *  UPLO    (input) CHARACTER*1
044: *          = 'U':  B is upper bidiagonal.
045: *          = 'L':  B is lower bidiagonal.
046: *
047: *  COMPQ   (input) CHARACTER*1
048: *          Specifies whether singular vectors are to be computed
049: *          as follows:
050: *          = 'N':  Compute singular values only;
051: *          = 'P':  Compute singular values and compute singular
052: *                  vectors in compact form;
053: *          = 'I':  Compute singular values and singular vectors.
054: *
055: *  N       (input) INTEGER
056: *          The order of the matrix B.  N >= 0.
057: *
058: *  D       (input/output) DOUBLE PRECISION array, dimension (N)
059: *          On entry, the n diagonal elements of the bidiagonal matrix B.
060: *          On exit, if INFO=0, the singular values of B.
061: *
062: *  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
063: *          On entry, the elements of E contain the offdiagonal
064: *          elements of the bidiagonal matrix whose SVD is desired.
065: *          On exit, E has been destroyed.
066: *
067: *  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
068: *          If  COMPQ = 'I', then:
069: *             On exit, if INFO = 0, U contains the left singular vectors
070: *             of the bidiagonal matrix.
071: *          For other values of COMPQ, U is not referenced.
072: *
073: *  LDU     (input) INTEGER
074: *          The leading dimension of the array U.  LDU >= 1.
075: *          If singular vectors are desired, then LDU >= max( 1, N ).
076: *
077: *  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
078: *          If  COMPQ = 'I', then:
079: *             On exit, if INFO = 0, VT' contains the right singular
080: *             vectors of the bidiagonal matrix.
081: *          For other values of COMPQ, VT is not referenced.
082: *
083: *  LDVT    (input) INTEGER
084: *          The leading dimension of the array VT.  LDVT >= 1.
085: *          If singular vectors are desired, then LDVT >= max( 1, N ).
086: *
087: *  Q       (output) DOUBLE PRECISION array, dimension (LDQ)
088: *          If  COMPQ = 'P', then:
089: *             On exit, if INFO = 0, Q and IQ contain the left
090: *             and right singular vectors in a compact form,
091: *             requiring O(N log N) space instead of 2*N**2.
092: *             In particular, Q contains all the DOUBLE PRECISION data in
093: *             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
094: *             words of memory, where SMLSIZ is returned by ILAENV and
095: *             is equal to the maximum size of the subproblems at the
096: *             bottom of the computation tree (usually about 25).
097: *          For other values of COMPQ, Q is not referenced.
098: *
099: *  IQ      (output) INTEGER array, dimension (LDIQ)
100: *          If  COMPQ = 'P', then:
101: *             On exit, if INFO = 0, Q and IQ contain the left
102: *             and right singular vectors in a compact form,
103: *             requiring O(N log N) space instead of 2*N**2.
104: *             In particular, IQ contains all INTEGER data in
105: *             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
106: *             words of memory, where SMLSIZ is returned by ILAENV and
107: *             is equal to the maximum size of the subproblems at the
108: *             bottom of the computation tree (usually about 25).
109: *          For other values of COMPQ, IQ is not referenced.
110: *
111: *  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
112: *          If COMPQ = 'N' then LWORK >= (4 * N).
113: *          If COMPQ = 'P' then LWORK >= (6 * N).
114: *          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
115: *
116: *  IWORK   (workspace) INTEGER array, dimension (8*N)
117: *
118: *  INFO    (output) INTEGER
119: *          = 0:  successful exit.
120: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
121: *          > 0:  The algorithm failed to compute an singular value.
122: *                The update process of divide and conquer failed.
123: *
124: *  Further Details
125: *  ===============
126: *
127: *  Based on contributions by
128: *     Ming Gu and Huan Ren, Computer Science Division, University of
129: *     California at Berkeley, USA
130: *
131: *  =====================================================================
132: *  Changed dimension statement in comment describing E from (N) to
133: *  (N-1).  Sven, 17 Feb 05.
134: *  =====================================================================
135: *
136: *     .. Parameters ..
137:       DOUBLE PRECISION   ZERO, ONE, TWO
138:       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
139: *     ..
140: *     .. Local Scalars ..
141:       INTEGER            DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
142:      \$                   ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
143:      \$                   MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
144:      \$                   SMLSZP, SQRE, START, WSTART, Z
145:       DOUBLE PRECISION   CS, EPS, ORGNRM, P, R, SN
146: *     ..
147: *     .. External Functions ..
148:       LOGICAL            LSAME
149:       INTEGER            ILAENV
150:       DOUBLE PRECISION   DLAMCH, DLANST
151:       EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
152: *     ..
153: *     .. External Subroutines ..
154:       EXTERNAL           DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ,
155:      \$                   DLASET, DLASR, DSWAP, XERBLA
156: *     ..
157: *     .. Intrinsic Functions ..
158:       INTRINSIC          ABS, DBLE, INT, LOG, SIGN
159: *     ..
160: *     .. Executable Statements ..
161: *
162: *     Test the input parameters.
163: *
164:       INFO = 0
165: *
166:       IUPLO = 0
167:       IF( LSAME( UPLO, 'U' ) )
168:      \$   IUPLO = 1
169:       IF( LSAME( UPLO, 'L' ) )
170:      \$   IUPLO = 2
171:       IF( LSAME( COMPQ, 'N' ) ) THEN
172:          ICOMPQ = 0
173:       ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
174:          ICOMPQ = 1
175:       ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
176:          ICOMPQ = 2
177:       ELSE
178:          ICOMPQ = -1
179:       END IF
180:       IF( IUPLO.EQ.0 ) THEN
181:          INFO = -1
182:       ELSE IF( ICOMPQ.LT.0 ) THEN
183:          INFO = -2
184:       ELSE IF( N.LT.0 ) THEN
185:          INFO = -3
186:       ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
187:      \$         N ) ) ) THEN
188:          INFO = -7
189:       ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
190:      \$         N ) ) ) THEN
191:          INFO = -9
192:       END IF
193:       IF( INFO.NE.0 ) THEN
194:          CALL XERBLA( 'DBDSDC', -INFO )
195:          RETURN
196:       END IF
197: *
198: *     Quick return if possible
199: *
200:       IF( N.EQ.0 )
201:      \$   RETURN
202:       SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
203:       IF( N.EQ.1 ) THEN
204:          IF( ICOMPQ.EQ.1 ) THEN
205:             Q( 1 ) = SIGN( ONE, D( 1 ) )
206:             Q( 1+SMLSIZ*N ) = ONE
207:          ELSE IF( ICOMPQ.EQ.2 ) THEN
208:             U( 1, 1 ) = SIGN( ONE, D( 1 ) )
209:             VT( 1, 1 ) = ONE
210:          END IF
211:          D( 1 ) = ABS( D( 1 ) )
212:          RETURN
213:       END IF
214:       NM1 = N - 1
215: *
216: *     If matrix lower bidiagonal, rotate to be upper bidiagonal
217: *     by applying Givens rotations on the left
218: *
219:       WSTART = 1
220:       QSTART = 3
221:       IF( ICOMPQ.EQ.1 ) THEN
222:          CALL DCOPY( N, D, 1, Q( 1 ), 1 )
223:          CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )
224:       END IF
225:       IF( IUPLO.EQ.2 ) THEN
226:          QSTART = 5
227:          WSTART = 2*N - 1
228:          DO 10 I = 1, N - 1
229:             CALL DLARTG( D( I ), E( I ), CS, SN, R )
230:             D( I ) = R
231:             E( I ) = SN*D( I+1 )
232:             D( I+1 ) = CS*D( I+1 )
233:             IF( ICOMPQ.EQ.1 ) THEN
234:                Q( I+2*N ) = CS
235:                Q( I+3*N ) = SN
236:             ELSE IF( ICOMPQ.EQ.2 ) THEN
237:                WORK( I ) = CS
238:                WORK( NM1+I ) = -SN
239:             END IF
240:    10    CONTINUE
241:       END IF
242: *
243: *     If ICOMPQ = 0, use DLASDQ to compute the singular values.
244: *
245:       IF( ICOMPQ.EQ.0 ) THEN
246:          CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
247:      \$                LDU, WORK( WSTART ), INFO )
248:          GO TO 40
249:       END IF
250: *
251: *     If N is smaller than the minimum divide size SMLSIZ, then solve
252: *     the problem with another solver.
253: *
254:       IF( N.LE.SMLSIZ ) THEN
255:          IF( ICOMPQ.EQ.2 ) THEN
256:             CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
257:             CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
258:             CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
259:      \$                   LDU, WORK( WSTART ), INFO )
260:          ELSE IF( ICOMPQ.EQ.1 ) THEN
261:             IU = 1
262:             IVT = IU + N
263:             CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
264:      \$                   N )
265:             CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
266:      \$                   N )
267:             CALL DLASDQ( 'U', 0, N, N, N, 0, D, E,
268:      \$                   Q( IVT+( QSTART-1 )*N ), N,
269:      \$                   Q( IU+( QSTART-1 )*N ), N,
270:      \$                   Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
271:      \$                   INFO )
272:          END IF
273:          GO TO 40
274:       END IF
275: *
276:       IF( ICOMPQ.EQ.2 ) THEN
277:          CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
278:          CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
279:       END IF
280: *
281: *     Scale.
282: *
283:       ORGNRM = DLANST( 'M', N, D, E )
284:       IF( ORGNRM.EQ.ZERO )
285:      \$   RETURN
286:       CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
287:       CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
288: *
289:       EPS = DLAMCH( 'Epsilon' )
290: *
291:       MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
292:       SMLSZP = SMLSIZ + 1
293: *
294:       IF( ICOMPQ.EQ.1 ) THEN
295:          IU = 1
296:          IVT = 1 + SMLSIZ
297:          DIFL = IVT + SMLSZP
298:          DIFR = DIFL + MLVL
299:          Z = DIFR + MLVL*2
300:          IC = Z + MLVL
301:          IS = IC + 1
302:          POLES = IS + 1
303:          GIVNUM = POLES + 2*MLVL
304: *
305:          K = 1
306:          GIVPTR = 2
307:          PERM = 3
308:          GIVCOL = PERM + MLVL
309:       END IF
310: *
311:       DO 20 I = 1, N
312:          IF( ABS( D( I ) ).LT.EPS ) THEN
313:             D( I ) = SIGN( EPS, D( I ) )
314:          END IF
315:    20 CONTINUE
316: *
317:       START = 1
318:       SQRE = 0
319: *
320:       DO 30 I = 1, NM1
321:          IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
322: *
323: *        Subproblem found. First determine its size and then
324: *        apply divide and conquer on it.
325: *
326:             IF( I.LT.NM1 ) THEN
327: *
328: *        A subproblem with E(I) small for I < NM1.
329: *
330:                NSIZE = I - START + 1
331:             ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
332: *
333: *        A subproblem with E(NM1) not too small but I = NM1.
334: *
335:                NSIZE = N - START + 1
336:             ELSE
337: *
338: *        A subproblem with E(NM1) small. This implies an
339: *        1-by-1 subproblem at D(N). Solve this 1-by-1 problem
340: *        first.
341: *
342:                NSIZE = I - START + 1
343:                IF( ICOMPQ.EQ.2 ) THEN
344:                   U( N, N ) = SIGN( ONE, D( N ) )
345:                   VT( N, N ) = ONE
346:                ELSE IF( ICOMPQ.EQ.1 ) THEN
347:                   Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
348:                   Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
349:                END IF
350:                D( N ) = ABS( D( N ) )
351:             END IF
352:             IF( ICOMPQ.EQ.2 ) THEN
353:                CALL DLASD0( NSIZE, SQRE, D( START ), E( START ),
354:      \$                      U( START, START ), LDU, VT( START, START ),
355:      \$                      LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
356:             ELSE
357:                CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
358:      \$                      E( START ), Q( START+( IU+QSTART-2 )*N ), N,
359:      \$                      Q( START+( IVT+QSTART-2 )*N ),
360:      \$                      IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
361:      \$                      N ), Q( START+( DIFR+QSTART-2 )*N ),
362:      \$                      Q( START+( Z+QSTART-2 )*N ),
363:      \$                      Q( START+( POLES+QSTART-2 )*N ),
364:      \$                      IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
365:      \$                      N, IQ( START+PERM*N ),
366:      \$                      Q( START+( GIVNUM+QSTART-2 )*N ),
367:      \$                      Q( START+( IC+QSTART-2 )*N ),
368:      \$                      Q( START+( IS+QSTART-2 )*N ),
369:      \$                      WORK( WSTART ), IWORK, INFO )
370:                IF( INFO.NE.0 ) THEN
371:                   RETURN
372:                END IF
373:             END IF
374:             START = I + 1
375:          END IF
376:    30 CONTINUE
377: *
378: *     Unscale
379: *
380:       CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
381:    40 CONTINUE
382: *
383: *     Use Selection Sort to minimize swaps of singular vectors
384: *
385:       DO 60 II = 2, N
386:          I = II - 1
387:          KK = I
388:          P = D( I )
389:          DO 50 J = II, N
390:             IF( D( J ).GT.P ) THEN
391:                KK = J
392:                P = D( J )
393:             END IF
394:    50    CONTINUE
395:          IF( KK.NE.I ) THEN
396:             D( KK ) = D( I )
397:             D( I ) = P
398:             IF( ICOMPQ.EQ.1 ) THEN
399:                IQ( I ) = KK
400:             ELSE IF( ICOMPQ.EQ.2 ) THEN
401:                CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
402:                CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
403:             END IF
404:          ELSE IF( ICOMPQ.EQ.1 ) THEN
405:             IQ( I ) = I
406:          END IF
407:    60 CONTINUE
408: *
409: *     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
410: *
411:       IF( ICOMPQ.EQ.1 ) THEN
412:          IF( IUPLO.EQ.1 ) THEN
413:             IQ( N ) = 1
414:          ELSE
415:             IQ( N ) = 0
416:          END IF
417:       END IF
418: *
419: *     If B is lower bidiagonal, update U by those Givens rotations
420: *     which rotated B to be upper bidiagonal
421: *
422:       IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
423:      \$   CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
424: *
425:       RETURN
426: *
427: *     End of DBDSDC
428: *
429:       END
430: ```