/* Subroutine */ int clalsa_(integer *icompq, integer *smlsiz, integer *n,
integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx,
real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr,
real *z__, real *poles, integer *givptr, integer *givcol, integer *
ldgcol, integer *perm, real *givnum, real *c__, real *s, real *rwork,
integer *iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CLALSA is an itermediate step in solving the least squares problem
by computing the SVD of the coefficient matrix in compact form (The
singular vectors are computed as products of simple orthorgonal
matrices.).
If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector
matrix of an upper bidiagonal matrix to the right hand side; and if
ICOMPQ = 1, CLALSA applies the right singular vector matrix to the
right hand side. The singular vector matrices were generated in
compact form by CLALSA.
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether the left or the right singular vector
matrix is involved.
= 0: Left singular vector matrix
= 1: Right singular vector matrix
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The row and column dimensions of the upper bidiagonal matrix.
NRHS (input) INTEGER
The number of columns of B and BX. NRHS must be at least 1.
B (input) COMPLEX array, dimension ( LDB, NRHS )
On input, B contains the right hand sides of the least
squares problem in rows 1 through M. On output, B contains
the solution X in rows 1 through N.
LDB (input) INTEGER
The leading dimension of B in the calling subprogram.
LDB must be at least max(1,MAX( M, N ) ).
BX (output) COMPLEX array, dimension ( LDBX, NRHS )
On exit, the result of applying the left or right singular
vector matrix to B.
LDBX (input) INTEGER
The leading dimension of BX.
U (input) REAL array, dimension ( LDU, SMLSIZ ).
On entry, U contains the left singular vector matrices of all
subproblems at the bottom level.
LDU (input) INTEGER, LDU = > N.
The leading dimension of arrays U, VT, DIFL, DIFR,
POLES, GIVNUM, and Z.
VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).
On entry, VT' contains the right singular vector matrices of
all subproblems at the bottom level.
K (input) INTEGER array, dimension ( N ).
DIFL (input) REAL array, dimension ( LDU, NLVL ).
where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).
On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
distances between singular values on the I-th level and
singular values on the (I -1)-th level, and DIFR(*, 2 * I)
record the normalizing factors of the right singular vectors
matrices of subproblems on I-th level.
Z (input) REAL array, dimension ( LDU, NLVL ).
On entry, Z(1, I) contains the components of the deflation-
adjusted updating row vector for subproblems on the I-th
level.
POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).
On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
singular values involved in the secular equations on the I-th
level.
GIVPTR (input) INTEGER array, dimension ( N ).
On entry, GIVPTR( I ) records the number of Givens
rotations performed on the I-th problem on the computation
tree.
GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
locations of Givens rotations performed on the I-th level on
the computation tree.
LDGCOL (input) INTEGER, LDGCOL = > N.
The leading dimension of arrays GIVCOL and PERM.
PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
On entry, PERM(*, I) records permutations done on the I-th
level of the computation tree.
GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).
On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
values of Givens rotations performed on the I-th level on the
computation tree.
C (input) REAL array, dimension ( N ).
On entry, if the I-th subproblem is not square,
C( I ) contains the C-value of a Givens rotation related to
the right null space of the I-th subproblem.
S (input) REAL array, dimension ( N ).
On entry, if the I-th subproblem is not square,
S( I ) contains the S-value of a Givens rotation related to
the right null space of the I-th subproblem.
RWORK (workspace) REAL array, dimension at least
max ( N, (SMLSZ+1)*NRHS*3 ).
IWORK (workspace) INTEGER array.
The dimension must be at least 3 * N
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b9 = 1.f;
static real c_b10 = 0.f;
static integer c__2 = 2;
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
z_dim1, z_offset, b_dim1, b_offset, bx_dim1, bx_offset, i__1,
i__2, i__3, i__4, i__5, i__6;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
integer pow_ii(integer *, integer *);
/* Local variables */
static integer jcol, nlvl, sqre, jrow, i__, j, jimag, jreal, inode, ndiml;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static integer ndimr;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer i1;
extern /* Subroutine */ int clals0_(integer *, integer *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
integer *, integer *, integer *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, real *, real *, real *,
integer *);
static integer ic, lf, nd, ll, nl, nr;
extern /* Subroutine */ int xerbla_(char *, integer *), slasdt_(
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
static integer im1, nlf, nrf, lvl, ndb1, nlp1, lvl2, nrp1;
#define difl_ref(a_1,a_2) difl[(a_2)*difl_dim1 + a_1]
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#define perm_ref(a_1,a_2) perm[(a_2)*perm_dim1 + a_1]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define bx_subscr(a_1,a_2) (a_2)*bx_dim1 + a_1
#define bx_ref(a_1,a_2) bx[bx_subscr(a_1,a_2)]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
bx_dim1 = *ldbx;
bx_offset = 1 + bx_dim1 * 1;
bx -= bx_offset;
givnum_dim1 = *ldu;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
poles_dim1 = *ldu;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
difr_dim1 = *ldu;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
difl_dim1 = *ldu;
difl_offset = 1 + difl_dim1 * 1;
difl -= difl_offset;
vt_dim1 = *ldu;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--k;
--givptr;
perm_dim1 = *ldgcol;
perm_offset = 1 + perm_dim1 * 1;
perm -= perm_offset;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
--c__;
--s;
--rwork;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
*info = -2;
} else if (*n < *smlsiz) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < *n) {
*info = -6;
} else if (*ldbx < *n) {
*info = -8;
} else if (*ldu < *n) {
*info = -10;
} else if (*ldgcol < *n) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLALSA", &i__1);
return 0;
}
/* Book-keeping and setting up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* The following code applies back the left singular vector factors.
For applying back the right singular vector factors, go to 170. */
if (*icompq == 1) {
goto L170;
}
/* The nodes on the bottom level of the tree were solved
by SLASDQ. The corresponding left and right singular vector
matrices are in explicit form. First apply back the left
singular vector matrices. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node
NL : number of rows of left subproblem
NR : number of rows of right subproblem
NLF: starting row of the left subproblem
NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
/* Since B and BX are complex, the following call to SGEMM
is performed in two steps (real and imaginary parts).
CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */
j = nl * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nlf + nl - 1;
for (jrow = nlf; jrow <= i__3; ++jrow) {
++j;
i__4 = b_subscr(jrow, jcol);
rwork[j] = b[i__4].r;
/* L10: */
}
/* L20: */
}
sgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u_ref(nlf, 1), ldu, &rwork[(
nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[1], &nl);
j = nl * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nlf + nl - 1;
for (jrow = nlf; jrow <= i__3; ++jrow) {
++j;
rwork[j] = r_imag(&b_ref(jrow, jcol));
/* L30: */
}
/* L40: */
}
sgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u_ref(nlf, 1), ldu, &rwork[(
nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[nl * *nrhs + 1], &
nl);
jreal = 0;
jimag = nl * *nrhs;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nlf + nl - 1;
for (jrow = nlf; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = bx_subscr(jrow, jcol);
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
/* L50: */
}
/* L60: */
}
/* Since B and BX are complex, the following call to SGEMM
is performed in two steps (real and imaginary parts).
CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */
j = nr * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nrf + nr - 1;
for (jrow = nrf; jrow <= i__3; ++jrow) {
++j;
i__4 = b_subscr(jrow, jcol);
rwork[j] = b[i__4].r;
/* L70: */
}
/* L80: */
}
sgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u_ref(nrf, 1), ldu, &rwork[(
nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[1], &nr);
j = nr * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nrf + nr - 1;
for (jrow = nrf; jrow <= i__3; ++jrow) {
++j;
rwork[j] = r_imag(&b_ref(jrow, jcol));
/* L90: */
}
/* L100: */
}
sgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u_ref(nrf, 1), ldu, &rwork[(
nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[nr * *nrhs + 1], &
nr);
jreal = 0;
jimag = nr * *nrhs;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nrf + nr - 1;
for (jrow = nrf; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = bx_subscr(jrow, jcol);
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* Next copy the rows of B that correspond to unchanged rows
in the bidiagonal matrix to BX. */
i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) {
ic = iwork[inode + i__ - 1];
ccopy_(nrhs, &b_ref(ic, 1), ldb, &bx_ref(ic, 1), ldbx);
/* L140: */
}
/* Finally go through the left singular vector matrices of all
the other subproblems bottom-up on the tree. */
j = pow_ii(&c__2, &nlvl);
sqre = 0;
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* find the first node LF and last node LL on
the current level LVL */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
--j;
clals0_(icompq, &nl, &nr, &sqre, nrhs, &bx_ref(nlf, 1), ldbx, &
b_ref(nlf, 1), ldb, &perm_ref(nlf, lvl), &givptr[j], &
givcol_ref(nlf, lvl2), ldgcol, &givnum_ref(nlf, lvl2),
ldu, &poles_ref(nlf, lvl2), &difl_ref(nlf, lvl), &
difr_ref(nlf, lvl2), &z___ref(nlf, lvl), &k[j], &c__[j], &
s[j], &rwork[1], info);
/* L150: */
}
/* L160: */
}
goto L330;
/* ICOMPQ = 1: applying back the right singular vector factors. */
L170:
/* First now go through the right singular vector matrices of all
the tree nodes top-down. */
j = 0;
i__1 = nlvl;
for (lvl = 1; lvl <= i__1; ++lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on
the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__2 = lvl - 1;
lf = pow_ii(&c__2, &i__2);
ll = (lf << 1) - 1;
}
i__2 = lf;
for (i__ = ll; i__ >= i__2; --i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
if (i__ == ll) {
sqre = 0;
} else {
sqre = 1;
}
++j;
clals0_(icompq, &nl, &nr, &sqre, nrhs, &b_ref(nlf, 1), ldb, &
bx_ref(nlf, 1), ldbx, &perm_ref(nlf, lvl), &givptr[j], &
givcol_ref(nlf, lvl2), ldgcol, &givnum_ref(nlf, lvl2),
ldu, &poles_ref(nlf, lvl2), &difl_ref(nlf, lvl), &
difr_ref(nlf, lvl2), &z___ref(nlf, lvl), &k[j], &c__[j], &
s[j], &rwork[1], info);
/* L180: */
}
/* L190: */
}
/* The nodes on the bottom level of the tree were solved
by SLASDQ. The corresponding right singular vector
matrices are in explicit form. Apply them back. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1];
nlp1 = nl + 1;
if (i__ == nd) {
nrp1 = nr;
} else {
nrp1 = nr + 1;
}
nlf = ic - nl;
nrf = ic + 1;
/* Since B and BX are complex, the following call to SGEMM is
performed in two steps (real and imaginary parts).
CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */
j = nlp1 * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nlf + nlp1 - 1;
for (jrow = nlf; jrow <= i__3; ++jrow) {
++j;
i__4 = b_subscr(jrow, jcol);
rwork[j] = b[i__4].r;
/* L200: */
}
/* L210: */
}
sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt_ref(nlf, 1), ldu, &
rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[1], &
nlp1);
j = nlp1 * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nlf + nlp1 - 1;
for (jrow = nlf; jrow <= i__3; ++jrow) {
++j;
rwork[j] = r_imag(&b_ref(jrow, jcol));
/* L220: */
}
/* L230: */
}
sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt_ref(nlf, 1), ldu, &
rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[nlp1 * *
nrhs + 1], &nlp1);
jreal = 0;
jimag = nlp1 * *nrhs;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nlf + nlp1 - 1;
for (jrow = nlf; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = bx_subscr(jrow, jcol);
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
/* L240: */
}
/* L250: */
}
/* Since B and BX are complex, the following call to SGEMM is
performed in two steps (real and imaginary parts).
CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */
j = nrp1 * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nrf + nrp1 - 1;
for (jrow = nrf; jrow <= i__3; ++jrow) {
++j;
i__4 = b_subscr(jrow, jcol);
rwork[j] = b[i__4].r;
/* L260: */
}
/* L270: */
}
sgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt_ref(nrf, 1), ldu, &
rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[1], &
nrp1);
j = nrp1 * *nrhs << 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nrf + nrp1 - 1;
for (jrow = nrf; jrow <= i__3; ++jrow) {
++j;
rwork[j] = r_imag(&b_ref(jrow, jcol));
/* L280: */
}
/* L290: */
}
sgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt_ref(nrf, 1), ldu, &
rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[nrp1 * *
nrhs + 1], &nrp1);
jreal = 0;
jimag = nrp1 * *nrhs;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = nrf + nrp1 - 1;
for (jrow = nrf; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = bx_subscr(jrow, jcol);
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
/* L300: */
}
/* L310: */
}
/* L320: */
}
L330:
return 0;
/* End of CLALSA */
} /* clalsa_ */
/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer
*ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr,
doublereal *z__, doublereal *poles, integer *givptr, integer *givcol,
integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
doublereal *s, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
z_dim1, z_offset, i__1, i__2;
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Local variables */
static doublereal beta;
static integer idxq, nlvl, i__, j, m;
static doublereal alpha;
static integer inode, ndiml, ndimr, idxqi, itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer sqrei, i1;
extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
static integer ic, nwork1, lf, nd, nwork2, ll, nl, vf, nr, vl;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
static integer im1, smlszp, ncc, nlf, nrf, vfi, iwk, vli, lvl, nru, ndb1,
nlp1, lvl2, nrp1;
#define difl_ref(a_1,a_2) difl[(a_2)*difl_dim1 + a_1]
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#define perm_ref(a_1,a_2) perm[(a_2)*perm_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
Using a divide and conquer approach, DLASDA computes the singular
value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
B with diagonal D and offdiagonal E, where M = N + SQRE. The
algorithm computes the singular values in the SVD B = U * S * VT.
The orthogonal matrices U and VT are optionally computed in
compact form.
A related subroutine, DLASD0, computes the singular values and
the singular vectors in explicit form.
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether singular vectors are to be computed
in compact form, as follows
= 0: Compute singular values only.
= 1: Compute singular vectors of upper bidiagonal
matrix in compact form.
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The row dimension of the upper bidiagonal matrix. This is
also the dimension of the main diagonal array D.
SQRE (input) INTEGER
Specifies the column dimension of the bidiagonal matrix.
= 0: The bidiagonal matrix has column dimension M = N;
= 1: The bidiagonal matrix has column dimension M = N + 1.
D (input/output) DOUBLE PRECISION array, dimension ( N )
On entry D contains the main diagonal of the bidiagonal
matrix. On exit D, if INFO = 0, contains its singular values.
E (input) DOUBLE PRECISION array, dimension ( M-1 )
Contains the subdiagonal entries of the bidiagonal matrix.
On exit, E has been destroyed.
U (output) DOUBLE PRECISION array,
dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
singular vector matrices of all subproblems at the bottom
level.
LDU (input) INTEGER, LDU = > N.
The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
GIVNUM, and Z.
VT (output) DOUBLE PRECISION array,
dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
singular vector matrices of all subproblems at the bottom
level.
K (output) INTEGER array,
dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
secular equation on the computation tree.
DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
where NLVL = floor(log_2 (N/SMLSIZ))).
DIFR (output) DOUBLE PRECISION array,
dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
dimension ( N ) if ICOMPQ = 0.
If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
record distances between singular values on the I-th
level and singular values on the (I -1)-th level, and
DIFR(1:N, 2 * I ) contains the normalizing factors for
the right singular vector matrix. See DLASD8 for details.
Z (output) DOUBLE PRECISION array,
dimension ( LDU, NLVL ) if ICOMPQ = 1 and
dimension ( N ) if ICOMPQ = 0.
The first K elements of Z(1, I) contain the components of
the deflation-adjusted updating row vector for subproblems
on the I-th level.
POLES (output) DOUBLE PRECISION array,
dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
POLES(1, 2*I) contain the new and old singular values
involved in the secular equations on the I-th level.
GIVPTR (output) INTEGER array,
dimension ( N ) if ICOMPQ = 1, and not referenced if
ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
the number of Givens rotations performed on the I-th
problem on the computation tree.
GIVCOL (output) INTEGER array,
dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
of Givens rotations performed on the I-th level on the
computation tree.
LDGCOL (input) INTEGER, LDGCOL = > N.
The leading dimension of arrays GIVCOL and PERM.
PERM (output) INTEGER array,
dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
permutations done on the I-th level of the computation tree.
GIVNUM (output) DOUBLE PRECISION array,
dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
values of Givens rotations performed on the I-th level on
the computation tree.
C (output) DOUBLE PRECISION array,
dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
C( I ) contains the C-value of a Givens rotation related to
the right null space of the I-th subproblem.
S (output) DOUBLE PRECISION array, dimension ( N ) if
ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
and the I-th subproblem is not square, on exit, S( I )
contains the S-value of a Givens rotation related to
the right null space of the I-th subproblem.
WORK (workspace) DOUBLE PRECISION array, dimension
(6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
IWORK (workspace) INTEGER array.
Dimension must be at least (7 * N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = 1, an singular value did not converge
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
givnum_dim1 = *ldu;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
poles_dim1 = *ldu;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
difr_dim1 = *ldu;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
difl_dim1 = *ldu;
difl_offset = 1 + difl_dim1 * 1;
difl -= difl_offset;
vt_dim1 = *ldu;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--k;
--givptr;
perm_dim1 = *ldgcol;
perm_offset = 1 + perm_dim1 * 1;
perm -= perm_offset;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
--c__;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
} else if (*ldu < *n + *sqre) {
*info = -8;
} else if (*ldgcol < *n) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASDA", &i__1);
return 0;
}
m = *n + *sqre;
/* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) {
if (*icompq == 0) {
dlasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
work[1], info);
} else {
dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
info);
}
return 0;
}
/* Book-keeping and set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
ncc = 0;
nru = 0;
smlszp = *smlsiz + 1;
vf = 1;
vl = vf + m;
nwork1 = vl + m;
nwork2 = nwork1 + smlszp * smlszp;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* for the nodes on bottom level of the tree, solve
their subproblems by DLASDQ. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node
NL : number of rows of left subproblem
NR : number of rows of right subproblem
NLF: starting row of the left subproblem
NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
idxqi = idxq + nlf - 2;
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
sqrei = 1;
if (*icompq == 0) {
dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
dlasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
&nl, &work[nwork2], info);
itemp = nwork1 + nl * smlszp;
dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_("A", &nl, &nl, &c_b11, &c_b12, &u_ref(nlf, 1), ldu);
dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt_ref(nlf, 1), ldu);
dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
vt_ref(nlf, 1), ldu, &u_ref(nlf, 1), ldu, &u_ref(nlf, 1),
ldu, &work[nwork1], info);
dcopy_(&nlp1, &vt_ref(nlf, 1), &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &vt_ref(nlf, nlp1), &c__1, &work[vli], &c__1);
}
if (*info != 0) {
return 0;
}
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L10: */
}
if (i__ == nd && *sqre == 0) {
sqrei = 0;
} else {
sqrei = 1;
}
idxqi += nlp1;
vfi += nlp1;
vli += nlp1;
nrp1 = nr + sqrei;
if (*icompq == 0) {
dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
dlasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
&nr, &work[nwork2], info);
itemp = nwork1 + (nrp1 - 1) * smlszp;
dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_("A", &nr, &nr, &c_b11, &c_b12, &u_ref(nrf, 1), ldu);
dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt_ref(nrf, 1), ldu);
dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
vt_ref(nrf, 1), ldu, &u_ref(nrf, 1), ldu, &u_ref(nrf, 1),
ldu, &work[nwork1], info);
dcopy_(&nrp1, &vt_ref(nrf, 1), &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &vt_ref(nrf, nrp1), &c__1, &work[vli], &c__1);
}
if (*info != 0) {
return 0;
}
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
j = pow_ii(&c__2, &nlvl);
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on
the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
if (i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
idxqi = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
if (*icompq == 0) {
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[
perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[
poles_offset], &difl[difl_offset], &difr[difr_offset],
&z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
&iwork[iwk], info);
} else {
--j;
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm_ref(
nlf, lvl), &givptr[j], &givcol_ref(nlf, lvl2), ldgcol,
&givnum_ref(nlf, lvl2), ldu, &poles_ref(nlf, lvl2), &
difl_ref(nlf, lvl), &difr_ref(nlf, lvl2), &z___ref(
nlf, lvl), &k[j], &c__[j], &s[j], &work[nwork1], &
iwork[iwk], info);
}
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of DLASDA */
} /* dlasda_ */
/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx,
integer *ldbx, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 1, 1999
Purpose
=======
SLALS0 applies back the multiplying factors of either the left or the
right singular vector matrix of a diagonal matrix appended by a row
to the right hand side matrix B in solving the least squares problem
using the divide-and-conquer SVD approach.
For the left singular vector matrix, three types of orthogonal
matrices are involved:
(1L) Givens rotations: the number of such rotations is GIVPTR; the
pairs of columns/rows they were applied to are stored in GIVCOL;
and the C- and S-values of these rotations are stored in GIVNUM.
(2L) Permutation. The (NL+1)-st row of B is to be moved to the first
row, and for J=2:N, PERM(J)-th row of B is to be moved to the
J-th row.
(3L) The left singular vector matrix of the remaining matrix.
For the right singular vector matrix, four types of orthogonal
matrices are involved:
(1R) The right singular vector matrix of the remaining matrix.
(2R) If SQRE = 1, one extra Givens rotation to generate the right
null space.
(3R) The inverse transformation of (2L).
(4R) The inverse transformation of (1L).
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether singular vectors are to be computed in
factored form:
= 0: Left singular vector matrix.
= 1: Right singular vector matrix.
NL (input) INTEGER
The row dimension of the upper block. NL >= 1.
NR (input) INTEGER
The row dimension of the lower block. NR >= 1.
SQRE (input) INTEGER
= 0: the lower block is an NR-by-NR square matrix.
= 1: the lower block is an NR-by-(NR+1) rectangular matrix.
The bidiagonal matrix has row dimension N = NL + NR + 1,
and column dimension M = N + SQRE.
NRHS (input) INTEGER
The number of columns of B and BX. NRHS must be at least 1.
B (input/output) REAL array, dimension ( LDB, NRHS )
On input, B contains the right hand sides of the least
squares problem in rows 1 through M. On output, B contains
the solution X in rows 1 through N.
LDB (input) INTEGER
The leading dimension of B. LDB must be at least
max(1,MAX( M, N ) ).
BX (workspace) REAL array, dimension ( LDBX, NRHS )
LDBX (input) INTEGER
The leading dimension of BX.
PERM (input) INTEGER array, dimension ( N )
The permutations (from deflation and sorting) applied
to the two blocks.
GIVPTR (input) INTEGER
The number of Givens rotations which took place in this
subproblem.
GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
Each pair of numbers indicates a pair of rows/columns
involved in a Givens rotation.
LDGCOL (input) INTEGER
The leading dimension of GIVCOL, must be at least N.
GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
Each number indicates the C or S value used in the
corresponding Givens rotation.
LDGNUM (input) INTEGER
The leading dimension of arrays DIFR, POLES and
GIVNUM, must be at least K.
POLES (input) REAL array, dimension ( LDGNUM, 2 )
On entry, POLES(1:K, 1) contains the new singular
values obtained from solving the secular equation, and
POLES(1:K, 2) is an array containing the poles in the secular
equation.
DIFL (input) REAL array, dimension ( K ).
On entry, DIFL(I) is the distance between I-th updated
(undeflated) singular value and the I-th (undeflated) old
singular value.
DIFR (input) REAL array, dimension ( LDGNUM, 2 ).
On entry, DIFR(I, 1) contains the distances between I-th
updated (undeflated) singular value and the I+1-th
(undeflated) old singular value. And DIFR(I, 2) is the
normalizing factor for the I-th right singular vector.
Z (input) REAL array, dimension ( K )
Contain the components of the deflation-adjusted updating row
vector.
K (input) INTEGER
Contains the dimension of the non-deflated matrix,
This is the order of the related secular equation. 1 <= K <=N.
C (input) REAL
C contains garbage if SQRE =0 and the C-value of a Givens
rotation related to the right null space if SQRE = 1.
S (input) REAL
S contains garbage if SQRE =0 and the S-value of a Givens
rotation related to the right null space if SQRE = 1.
WORK (workspace) REAL array, dimension ( K )
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b5 = -1.f;
static integer c__1 = 1;
static real c_b11 = 1.f;
static real c_b13 = 0.f;
static integer c__0 = 0;
/* System generated locals */
integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
poles_offset, i__1, i__2;
real r__1;
/* Local variables */
static real temp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
static integer i__, j, m, n;
static real diflj, difrj, dsigj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *), scopy_(
integer *, real *, integer *, real *, integer *);
extern doublereal slamc3_(real *, real *);
static real dj;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real dsigjp;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *);
static integer nlp1;
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define bx_ref(a_1,a_2) bx[(a_2)*bx_dim1 + a_1]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
bx_dim1 = *ldbx;
bx_offset = 1 + bx_dim1 * 1;
bx -= bx_offset;
--perm;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
difr_dim1 = *ldgnum;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
poles_dim1 = *ldgnum;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
--difl;
--z__;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
*info = -2;
} else if (*nr < 1) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
}
n = *nl + *nr + 1;
if (*nrhs < 1) {
*info = -5;
} else if (*ldb < n) {
*info = -7;
} else if (*ldbx < n) {
*info = -9;
} else if (*givptr < 0) {
*info = -11;
} else if (*ldgcol < n) {
*info = -13;
} else if (*ldgnum < n) {
*info = -15;
} else if (*k < 1) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLALS0", &i__1);
return 0;
}
m = n + *sqre;
nlp1 = *nl + 1;
if (*icompq == 0) {
/* Apply back orthogonal transformations from the left.
Step (1L): apply back the Givens rotations performed. */
i__1 = *givptr;
for (i__ = 1; i__ <= i__1; ++i__) {
srot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(givcol_ref(
i__, 1), 1), ldb, &givnum_ref(i__, 2), &givnum_ref(i__, 1)
);
/* L10: */
}
/* Step (2L): permute rows of B. */
scopy_(nrhs, &b_ref(nlp1, 1), ldb, &bx_ref(1, 1), ldbx);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
scopy_(nrhs, &b_ref(perm[i__], 1), ldb, &bx_ref(i__, 1), ldbx);
/* L20: */
}
/* Step (3L): apply the inverse of the left singular vector
matrix to BX. */
if (*k == 1) {
scopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.f) {
sscal_(nrhs, &c_b5, &b[b_offset], ldb);
}
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = poles_ref(j, 1);
dsigj = -poles_ref(j, 2);
if (j < *k) {
difrj = -difr_ref(j, 1);
dsigjp = -poles_ref(j + 1, 2);
}
if (z__[j] == 0.f || poles_ref(j, 2) == 0.f) {
work[j] = 0.f;
} else {
work[j] = -poles_ref(j, 2) * z__[j] / diflj / (poles_ref(
j, 2) + dj);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) {
work[i__] = 0.f;
} else {
work[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigj) - diflj) / (
poles_ref(i__, 2) + dj);
}
/* L30: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) {
work[i__] = 0.f;
} else {
work[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigjp) + difrj) / (
poles_ref(i__, 2) + dj);
}
/* L40: */
}
work[1] = -1.f;
temp = snrm2_(k, &work[1], &c__1);
sgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
c__1, &c_b13, &b_ref(j, 1), ldb);
slascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b_ref(
j, 1), ldb, info);
/* L50: */
}
}
/* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) {
i__1 = n - *k;
slacpy_("A", &i__1, nrhs, &bx_ref(*k + 1, 1), ldbx, &b_ref(*k + 1,
1), ldb);
}
} else {
/* Apply back the right orthogonal transformations.
Step (1R): apply back the new right singular vector matrix
to B. */
if (*k == 1) {
scopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dsigj = poles_ref(j, 2);
if (z__[j] == 0.f) {
work[j] = 0.f;
} else {
work[j] = -z__[j] / difl[j] / (dsigj + poles_ref(j, 1)) /
difr_ref(j, 2);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
work[i__] = 0.f;
} else {
r__1 = -poles_ref(i__ + 1, 2);
work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) -
difr_ref(i__, 1)) / (dsigj + poles_ref(i__, 1)
) / difr_ref(i__, 2);
}
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
work[i__] = 0.f;
} else {
r__1 = -poles_ref(i__, 2);
work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
i__]) / (dsigj + poles_ref(i__, 1)) /
difr_ref(i__, 2);
}
/* L70: */
}
sgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
c__1, &c_b13, &bx_ref(j, 1), ldbx);
/* L80: */
}
}
/* Step (2R): if SQRE = 1, apply back the rotation that is
related to the right null space of the subproblem. */
if (*sqre == 1) {
scopy_(nrhs, &b_ref(m, 1), ldb, &bx_ref(m, 1), ldbx);
srot_(nrhs, &bx_ref(1, 1), ldbx, &bx_ref(m, 1), ldbx, c__, s);
}
if (*k < max(m,n)) {
i__1 = n - *k;
slacpy_("A", &i__1, nrhs, &b_ref(*k + 1, 1), ldb, &bx_ref(*k + 1,
1), ldbx);
}
/* Step (3R): permute rows of B. */
scopy_(nrhs, &bx_ref(1, 1), ldbx, &b_ref(nlp1, 1), ldb);
if (*sqre == 1) {
scopy_(nrhs, &bx_ref(m, 1), ldbx, &b_ref(m, 1), ldb);
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
scopy_(nrhs, &bx_ref(i__, 1), ldbx, &b_ref(perm[i__], 1), ldb);
/* L90: */
}
/* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) {
r__1 = -givnum_ref(i__, 1);
srot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(givcol_ref(
i__, 1), 1), ldb, &givnum_ref(i__, 2), &r__1);
/* L100: */
}
}
return 0;
/* End of SLALS0 */
} /* slals0_ */
/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
work, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
Courant Institute, NAG Ltd., and Rice University
June 30, 1999
Purpose
=======
DLASD8 finds the square roots of the roots of the secular equation,
as defined by the values in DSIGMA and Z. It makes the appropriate
calls to DLASD4, and stores, for each element in D, the distance
to its two nearest poles (elements in DSIGMA). It also updates
the arrays VF and VL, the first and last components of all the
right singular vectors of the original bidiagonal matrix.
DLASD8 is called from DLASD6.
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether singular vectors are to be computed in
factored form in the calling routine:
= 0: Compute singular values only.
= 1: Compute singular vectors in factored form as well.
K (input) INTEGER
The number of terms in the rational function to be solved
by DLASD4. K >= 1.
D (output) DOUBLE PRECISION array, dimension ( K )
On output, D contains the updated singular values.
Z (input) DOUBLE PRECISION array, dimension ( K )
The first K elements of this array contain the components
of the deflation-adjusted updating row vector.
VF (input/output) DOUBLE PRECISION array, dimension ( K )
On entry, VF contains information passed through DBEDE8.
On exit, VF contains the first K components of the first
components of all right singular vectors of the bidiagonal
matrix.
VL (input/output) DOUBLE PRECISION array, dimension ( K )
On entry, VL contains information passed through DBEDE8.
On exit, VL contains the first K components of the last
components of all right singular vectors of the bidiagonal
matrix.
DIFL (output) DOUBLE PRECISION array, dimension ( K )
On exit, DIFL(I) = D(I) - DSIGMA(I).
DIFR (output) DOUBLE PRECISION array,
dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
dimension ( K ) if ICOMPQ = 0.
On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
defined and will not be referenced.
If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
normalizing factors for the right singular vector matrix.
LDDIFR (input) INTEGER
The leading dimension of DIFR, must be at least K.
DSIGMA (input) DOUBLE PRECISION array, dimension ( K )
The first K elements of this array contain the old roots
of the deflated updating problem. These are the poles
of the secular equation.
WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = 1, an singular value did not converge
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b8 = 1.;
/* System generated locals */
integer difr_dim1, difr_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer iwk2i, iwk3i, i__, j;
static doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
static doublereal dj;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal dsigjp, rho;
static integer iwk1, iwk2, iwk3;
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
--d__;
--z__;
--vf;
--vl;
--difl;
difr_dim1 = *lddifr;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
--dsigma;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*k < 1) {
*info = -2;
} else if (*lddifr < *k) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD8", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = abs(z__[1]);
difl[1] = d__[1];
if (*icompq == 1) {
difl[2] = 1.;
difr_ref(1, 2) = 1.;
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
be computed with high relative accuracy (barring over/underflow).
This is a problem on machines without a guard digit in
add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
which on any of these machines zeros out the bottommost
bit of DSIGMA(I) if it is 1; this makes the subsequent
subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
occurs. On binary machines with a guard digit (almost all
machines) it does not change DSIGMA(I) at all. On hexadecimal
and decimal machines with a guard digit, it slightly
changes the bottommost bits of DSIGMA(I). It does not account
for hexadecimal or decimal machines without guard digits
(we know of none). We use a subroutine call to compute
2*DLAMBDA(I) to prevent optimizing compilers from eliminating
this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L10: */
}
/* Book keeping. */
iwk1 = 1;
iwk2 = iwk1 + *k;
iwk3 = iwk2 + *k;
iwk2i = iwk2 - 1;
iwk3i = iwk3 - 1;
/* Normalize Z. */
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
rho *= rho;
/* Initialize WORK(IWK3). */
dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
/* Compute the updated singular values, the arrays DIFL, DIFR,
and the updated Z. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
iwk2], info);
/* If the root finder fails, the computation is terminated. */
if (*info != 0) {
return 0;
}
work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
difl[j] = -work[j];
difr_ref(j, 1) = -work[j + 1];
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L20: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L30: */
}
/* L40: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
z__[i__] = d_sign(&d__2, &z__[i__]);
/* L50: */
}
/* Update VF and VL. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = d__[j];
dsigj = -dsigma[j];
if (j < *k) {
difrj = -difr_ref(j, 1);
dsigjp = -dsigma[j + 1];
}
work[j] = -z__[j] / diflj / (dsigma[j] + dj);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
dsigma[i__] + dj);
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
(dsigma[i__] + dj);
/* L70: */
}
temp = dnrm2_(k, &work[1], &c__1);
work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
if (*icompq == 1) {
difr_ref(j, 2) = temp;
}
/* L80: */
}
dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
return 0;
/* End of DLASD8 */
} /* dlasd8_ */
/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n,
integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *
ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k,
doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
work, integer *iwork, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1,
b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1,
difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset,
u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1,
i__2;
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Local variables */
static integer nlvl, sqre, i__, j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer inode, ndiml, ndimr;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer i1;
extern /* Subroutine */ int dlals0_(integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *);
extern doublereal dopbl3_(char *, integer *, integer *, integer *)
;
static integer ic, lf, nd, ll, nl, nr;
extern /* Subroutine */ int dlasdt_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *), xerbla_(char *,
integer *);
static integer im1, nlf, nrf, lvl, ndb1, nlp1, lvl2, nrp1;
#define difl_ref(a_1,a_2) difl[(a_2)*difl_dim1 + a_1]
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#define perm_ref(a_1,a_2) perm[(a_2)*perm_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define bx_ref(a_1,a_2) bx[(a_2)*bx_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
/* -- LAPACK routine (instrumented to count ops, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DLALSA is an itermediate step in solving the least squares problem
by computing the SVD of the coefficient matrix in compact form (The
singular vectors are computed as products of simple orthorgonal
matrices.).
If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector
matrix of an upper bidiagonal matrix to the right hand side; and if
ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
right hand side. The singular vector matrices were generated in
compact form by DLALSA.
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether the left or the right singular vector
matrix is involved.
= 0: Left singular vector matrix
= 1: Right singular vector matrix
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The row and column dimensions of the upper bidiagonal matrix.
NRHS (input) INTEGER
The number of columns of B and BX. NRHS must be at least 1.
B (input) DOUBLE PRECISION array, dimension ( LDB, NRHS )
On input, B contains the right hand sides of the least
squares problem in rows 1 through M. On output, B contains
the solution X in rows 1 through N.
LDB (input) INTEGER
The leading dimension of B in the calling subprogram.
LDB must be at least max(1,MAX( M, N ) ).
BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
On exit, the result of applying the left or right singular
vector matrix to B.
LDBX (input) INTEGER
The leading dimension of BX.
U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
On entry, U contains the left singular vector matrices of all
subproblems at the bottom level.
LDU (input) INTEGER, LDU = > N.
The leading dimension of arrays U, VT, DIFL, DIFR,
POLES, GIVNUM, and Z.
VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
On entry, VT' contains the right singular vector matrices of
all subproblems at the bottom level.
K (input) INTEGER array, dimension ( N ).
DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
distances between singular values on the I-th level and
singular values on the (I -1)-th level, and DIFR(*, 2 * I)
record the normalizing factors of the right singular vectors
matrices of subproblems on I-th level.
Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
On entry, Z(1, I) contains the components of the deflation-
adjusted updating row vector for subproblems on the I-th
level.
POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
singular values involved in the secular equations on the I-th
level.
GIVPTR (input) INTEGER array, dimension ( N ).
On entry, GIVPTR( I ) records the number of Givens
rotations performed on the I-th problem on the computation
tree.
GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
locations of Givens rotations performed on the I-th level on
the computation tree.
LDGCOL (input) INTEGER, LDGCOL = > N.
The leading dimension of arrays GIVCOL and PERM.
PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
On entry, PERM(*, I) records permutations done on the I-th
level of the computation tree.
GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
values of Givens rotations performed on the I-th level on the
computation tree.
C (input) DOUBLE PRECISION array, dimension ( N ).
On entry, if the I-th subproblem is not square,
C( I ) contains the C-value of a Givens rotation related to
the right null space of the I-th subproblem.
S (input) DOUBLE PRECISION array, dimension ( N ).
On entry, if the I-th subproblem is not square,
S( I ) contains the S-value of a Givens rotation related to
the right null space of the I-th subproblem.
WORK (workspace) DOUBLE PRECISION array.
The dimension must be at least N.
IWORK (workspace) INTEGER array.
The dimension must be at least 3 * N
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
bx_dim1 = *ldbx;
bx_offset = 1 + bx_dim1 * 1;
bx -= bx_offset;
givnum_dim1 = *ldu;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
poles_dim1 = *ldu;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
difr_dim1 = *ldu;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
difl_dim1 = *ldu;
difl_offset = 1 + difl_dim1 * 1;
difl -= difl_offset;
vt_dim1 = *ldu;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--k;
--givptr;
perm_dim1 = *ldgcol;
perm_offset = 1 + perm_dim1 * 1;
perm -= perm_offset;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
--c__;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
*info = -2;
} else if (*n < *smlsiz) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < *n) {
*info = -6;
} else if (*ldbx < *n) {
*info = -8;
} else if (*ldu < *n) {
*info = -10;
} else if (*ldgcol < *n) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLALSA", &i__1);
return 0;
}
/* Book-keeping and setting up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* The following code applies back the left singular vector factors.
For applying back the right singular vector factors, go to 50. */
if (*icompq == 1) {
goto L50;
}
/* The nodes on the bottom level of the tree were solved by DLASDQ.
The corresponding left and right singular vector matrices are in
explicit form. First apply back the left singular vector matrices. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node
NL : number of rows of left subproblem
NR : number of rows of right subproblem
NLF: starting row of the left subproblem
NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
latime_1.ops += dopbl3_("DGEMM ", &nl, nrhs, &nl);
latime_1.ops += dopbl3_("DGEMM ", &nr, nrhs, &nr);
dgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u_ref(nlf, 1), ldu, &b_ref(
nlf, 1), ldb, &c_b10, &bx_ref(nlf, 1), ldbx);
dgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u_ref(nrf, 1), ldu, &b_ref(
nrf, 1), ldb, &c_b10, &bx_ref(nrf, 1), ldbx);
/* L10: */
}
/* Next copy the rows of B that correspond to unchanged rows
in the bidiagonal matrix to BX. */
i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) {
ic = iwork[inode + i__ - 1];
dcopy_(nrhs, &b_ref(ic, 1), ldb, &bx_ref(ic, 1), ldbx);
/* L20: */
}
/* Finally go through the left singular vector matrices of all
the other subproblems bottom-up on the tree. */
j = pow_ii(&c__2, &nlvl);
sqre = 0;
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* find the first node LF and last node LL on
the current level LVL */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
--j;
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx_ref(nlf, 1), ldbx, &
b_ref(nlf, 1), ldb, &perm_ref(nlf, lvl), &givptr[j], &
givcol_ref(nlf, lvl2), ldgcol, &givnum_ref(nlf, lvl2),
ldu, &poles_ref(nlf, lvl2), &difl_ref(nlf, lvl), &
difr_ref(nlf, lvl2), &z___ref(nlf, lvl), &k[j], &c__[j], &
s[j], &work[1], info);
/* L30: */
}
/* L40: */
}
goto L90;
/* ICOMPQ = 1: applying back the right singular vector factors. */
L50:
/* First now go through the right singular vector matrices of all
the tree nodes top-down. */
j = 0;
i__1 = nlvl;
for (lvl = 1; lvl <= i__1; ++lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on
the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__2 = lvl - 1;
lf = pow_ii(&c__2, &i__2);
ll = (lf << 1) - 1;
}
i__2 = lf;
for (i__ = ll; i__ >= i__2; --i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
if (i__ == ll) {
sqre = 0;
} else {
sqre = 1;
}
++j;
dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b_ref(nlf, 1), ldb, &
bx_ref(nlf, 1), ldbx, &perm_ref(nlf, lvl), &givptr[j], &
givcol_ref(nlf, lvl2), ldgcol, &givnum_ref(nlf, lvl2),
ldu, &poles_ref(nlf, lvl2), &difl_ref(nlf, lvl), &
difr_ref(nlf, lvl2), &z___ref(nlf, lvl), &k[j], &c__[j], &
s[j], &work[1], info);
/* L60: */
}
/* L70: */
}
/* The nodes on the bottom level of the tree were solved by DLASDQ.
The corresponding right singular vector matrices are in explicit
form. Apply them back. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nr = iwork[ndimr + i1];
nlp1 = nl + 1;
if (i__ == nd) {
nrp1 = nr;
} else {
nrp1 = nr + 1;
}
nlf = ic - nl;
nrf = ic + 1;
latime_1.ops += dopbl3_("DGEMM ", &nlp1, nrhs, &nlp1);
latime_1.ops += dopbl3_("DGEMM ", &nrp1, nrhs, &nrp1);
dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt_ref(nlf, 1), ldu, &
b_ref(nlf, 1), ldb, &c_b10, &bx_ref(nlf, 1), ldbx);
dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt_ref(nrf, 1), ldu, &
b_ref(nrf, 1), ldb, &c_b10, &bx_ref(nrf, 1), ldbx);
/* L80: */
}
L90:
return 0;
/* End of DLALSA */
} /* dlalsa_ */
