272 SUBROUTINE slasda( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
273 $ difl, difr, z, poles, givptr, givcol, ldgcol,
274 $ perm, givnum, c, s, work, iwork, info )
282 INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
285 INTEGER GIVCOL( ldgcol, * ), GIVPTR( * ), IWORK( * ),
286 $ k( * ), perm( ldgcol, * )
287 REAL C( * ), D( * ), DIFL( ldu, * ), DIFR( ldu, * ),
288 $ e( * ), givnum( ldu, * ), poles( ldu, * ),
289 $ s( * ), u( ldu, * ), vt( ldu, * ), work( * ),
297 parameter ( zero = 0.0e+0, one = 1.0e+0 )
300 INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
301 $ j, lf, ll, lvl, lvl2, m, ncc, nd, ndb1, ndiml,
302 $ ndimr, nl, nlf, nlp1, nlvl, nr, nrf, nrp1, nru,
303 $ nwork1, nwork2, smlszp, sqrei, vf, vfi, vl, vli
315 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) )
THEN
317 ELSE IF( smlsiz.LT.3 )
THEN
319 ELSE IF( n.LT.0 )
THEN
321 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) )
THEN
323 ELSE IF( ldu.LT.( n+sqre ) )
THEN
325 ELSE IF( ldgcol.LT.n )
THEN
329 CALL xerbla(
'SLASDA', -info )
337 IF( n.LE.smlsiz )
THEN
338 IF( icompq.EQ.0 )
THEN
339 CALL slasdq(
'U', sqre, n, 0, 0, 0, d, e, vt, ldu, u, ldu,
340 $ u, ldu, work, info )
342 CALL slasdq(
'U', sqre, n, m, n, 0, d, e, vt, ldu, u, ldu,
343 $ u, ldu, work, info )
363 nwork2 = nwork1 + smlszp*smlszp
365 CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
366 $ iwork( ndimr ), smlsiz )
381 ic = iwork( inode+i1 )
382 nl = iwork( ndiml+i1 )
384 nr = iwork( ndimr+i1 )
387 idxqi = idxq + nlf - 2
391 IF( icompq.EQ.0 )
THEN
392 CALL slaset(
'A', nlp1, nlp1, zero, one, work( nwork1 ),
394 CALL slasdq(
'U', sqrei, nl, nlp1, nru, ncc, d( nlf ),
395 $ e( nlf ), work( nwork1 ), smlszp,
396 $ work( nwork2 ), nl, work( nwork2 ), nl,
397 $ work( nwork2 ), info )
398 itemp = nwork1 + nl*smlszp
399 CALL scopy( nlp1, work( nwork1 ), 1, work( vfi ), 1 )
400 CALL scopy( nlp1, work( itemp ), 1, work( vli ), 1 )
402 CALL slaset(
'A', nl, nl, zero, one, u( nlf, 1 ), ldu )
403 CALL slaset(
'A', nlp1, nlp1, zero, one, vt( nlf, 1 ), ldu )
404 CALL slasdq(
'U', sqrei, nl, nlp1, nl, ncc, d( nlf ),
405 $ e( nlf ), vt( nlf, 1 ), ldu, u( nlf, 1 ), ldu,
406 $ u( nlf, 1 ), ldu, work( nwork1 ), info )
407 CALL scopy( nlp1, vt( nlf, 1 ), 1, work( vfi ), 1 )
408 CALL scopy( nlp1, vt( nlf, nlp1 ), 1, work( vli ), 1 )
416 IF( ( i.EQ.nd ) .AND. ( sqre.EQ.0 ) )
THEN
425 IF( icompq.EQ.0 )
THEN
426 CALL slaset(
'A', nrp1, nrp1, zero, one, work( nwork1 ),
428 CALL slasdq(
'U', sqrei, nr, nrp1, nru, ncc, d( nrf ),
429 $ e( nrf ), work( nwork1 ), smlszp,
430 $ work( nwork2 ), nr, work( nwork2 ), nr,
431 $ work( nwork2 ), info )
432 itemp = nwork1 + ( nrp1-1 )*smlszp
433 CALL scopy( nrp1, work( nwork1 ), 1, work( vfi ), 1 )
434 CALL scopy( nrp1, work( itemp ), 1, work( vli ), 1 )
436 CALL slaset(
'A', nr, nr, zero, one, u( nrf, 1 ), ldu )
437 CALL slaset(
'A', nrp1, nrp1, zero, one, vt( nrf, 1 ), ldu )
438 CALL slasdq(
'U', sqrei, nr, nrp1, nr, ncc, d( nrf ),
439 $ e( nrf ), vt( nrf, 1 ), ldu, u( nrf, 1 ), ldu,
440 $ u( nrf, 1 ), ldu, work( nwork1 ), info )
441 CALL scopy( nrp1, vt( nrf, 1 ), 1, work( vfi ), 1 )
442 CALL scopy( nrp1, vt( nrf, nrp1 ), 1, work( vli ), 1 )
455 DO 50 lvl = nlvl, 1, -1
470 ic = iwork( inode+im1 )
471 nl = iwork( ndiml+im1 )
472 nr = iwork( ndimr+im1 )
482 idxqi = idxq + nlf - 1
485 IF( icompq.EQ.0 )
THEN
486 CALL slasd6( icompq, nl, nr, sqrei, d( nlf ),
487 $ work( vfi ), work( vli ), alpha, beta,
488 $ iwork( idxqi ), perm, givptr( 1 ), givcol,
489 $ ldgcol, givnum, ldu, poles, difl, difr, z,
490 $ k( 1 ), c( 1 ), s( 1 ), work( nwork1 ),
491 $ iwork( iwk ), info )
494 CALL slasd6( icompq, nl, nr, sqrei, d( nlf ),
495 $ work( vfi ), work( vli ), alpha, beta,
496 $ iwork( idxqi ), perm( nlf, lvl ),
497 $ givptr( j ), givcol( nlf, lvl2 ), ldgcol,
498 $ givnum( nlf, lvl2 ), ldu,
499 $ poles( nlf, lvl2 ), difl( nlf, lvl ),
500 $ difr( nlf, lvl2 ), z( nlf, lvl ), k( j ),
501 $ c( j ), s( j ), work( nwork1 ),
502 $ iwork( iwk ), info )
subroutine slasdq(UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
SLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e...
subroutine slasda(ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO)
SLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagona...
subroutine xerbla(SRNAME, INFO)
XERBLA
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...
subroutine slasdt(N, LVL, ND, INODE, NDIML, NDIMR, MSUB)
SLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.
subroutine slasd6(ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO)
SLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY