/* Subroutine */ int check0_(doublereal *sfac)
{
/* Initialized data */
static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer k;
extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
*, doublereal *), stest1_(doublereal *, doublereal *, doublereal *
, doublereal *);
static doublereal sa, sb, sc, ss;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
/* Compute true values which cannot be prestored
in decimal notation */
dbtrue[0] = 1.6666666666666667;
dbtrue[2] = -1.6666666666666667;
dbtrue[4] = 1.6666666666666667;
for (k = 1; k <= 8; ++k) {
combla_1.n = k;
if (combla_1.icase == 3) {
if (k > 8) {
goto L40;
}
sa = da1[k - 1];
sb = db1[k - 1];
drotg_(&sa, &sb, &sc, &ss);
stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
} else {
s_wsle(&io___19);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L20: */
}
L40:
return 0;
} /* check0_
int
f2c_drotg(doublereal* a,
doublereal* b,
doublereal* c,
doublereal* s)
{
drotg_(a, b, c, s);
return 0;
}
/* Subroutine */ int dsvdc_(doublereal *x, integer *ldx, integer *n, integer *
p, doublereal *s, doublereal *e, doublereal *u, integer *ldu,
doublereal *v, integer *ldv, doublereal *work, integer *job, integer *
info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
static doublereal b, c__, f, g;
static integer i__, j, k, l, m;
static doublereal t, t1, el;
static integer kk;
static doublereal cs;
static integer ll, mm, ls;
static doublereal sl;
static integer lu;
static doublereal sm, sn;
static integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
static doublereal emm1, smm1;
static integer kase;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jobu, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal test;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer nctp1, nrtp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal scale, shift;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), drotg_(doublereal *, doublereal *,
doublereal *, doublereal *);
static integer maxit;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical wantu, wantv;
static doublereal ztest;
/* dsvdc is a subroutine to reduce a double precision nxp matrix x */
/* by orthogonal transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x double precision(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by dsvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u. */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v. */
/* (see below). */
/* work double precision(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 return the first min(n,p) singular */
/* vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s double precision(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e double precision(p), */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u double precision(ldu,k), where ldu.ge.n. if */
/* joba.eq.1 then k.eq.n, if joba.ge.2 */
/* then k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.eq.2, then u may be identified with x */
/* in the subroutine call. */
/* v double precision(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if job.eq.0. if p.le.n, */
/* then v may be identified with x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = trans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (trans(u) */
/* is the transpose of u). thus the singular */
/* values of x and b are the same. */
/* linpack. this version dated 08/14/78 . */
/* correction made to shift 2/84. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* dsvdc uses the following functions and subprograms. */
/* external drot */
/* blas daxpy,ddot,dscal,dswap,dnrm2,drotg */
/* fortran dabs,dmax1,max0,min0,mod,dsqrt */
/* internal variables */
/* set the maximum number of iterations. */
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 30;
/* determine what is to be computed. */
wantu = FALSE_;
wantv = FALSE_;
jobu = *job % 100 / 10;
ncu = *n;
if (jobu > 1) {
ncu = min(*n,*p);
}
if (jobu != 0) {
wantu = TRUE_;
}
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
*info = 0;
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
lu = max(nct,nrt);
if (lu < 1) {
goto L170;
}
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
lp1 = l + 1;
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
i__2 = *n - l + 1;
s[l] = dnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
if (s[l] == 0.) {
goto L10;
}
if (x[l + l * x_dim1] != 0.) {
s[l] = d_sign(&s[l], &x[l + l * x_dim1]);
}
i__2 = *n - l + 1;
d__1 = 1. / s[l];
dscal_(&i__2, &d__1, &x[l + l * x_dim1], &c__1);
x[l + l * x_dim1] += 1.;
L10:
s[l] = -s[l];
L20:
if (*p < lp1) {
goto L50;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
if (l > nct) {
goto L30;
}
if (s[l] == 0.) {
goto L30;
}
/* apply the transformation. */
i__3 = *n - l + 1;
t = -ddot_(&i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1) / x[l + l * x_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
e[j] = x[l + j * x_dim1];
/* L40: */
}
L50:
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = x[i__ + l * x_dim1];
/* L60: */
}
L70:
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
i__2 = *p - l;
e[l] = dnrm2_(&i__2, &e[lp1], &c__1);
if (e[l] == 0.) {
goto L80;
}
if (e[lp1] != 0.) {
e[l] = d_sign(&e[l], &e[lp1]);
}
i__2 = *p - l;
d__1 = 1. / e[l];
dscal_(&i__2, &d__1, &e[lp1], &c__1);
e[lp1] += 1.;
L80:
e[l] = -e[l];
if (lp1 > *n || e[l] == 0.) {
goto L120;
}
/* apply the transformation. */
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
work[i__] = 0.;
/* L90: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
daxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/* L100: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
d__1 = -e[j] / e[lp1];
daxpy_(&i__3, &d__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/* L110: */
}
L120:
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = e[i__];
/* L130: */
}
L140:
L150:
/* L160: */
;
}
L170:
/* set up the final bidiagonal matrix or order m. */
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
nctp1 = nct + 1;
nrtp1 = nrt + 1;
if (nct < *p) {
s[nctp1] = x[nctp1 + nctp1 * x_dim1];
}
if (*n < m) {
s[m] = 0.;
}
if (nrtp1 < m) {
e[nrtp1] = x[nrtp1 + m * x_dim1];
}
e[m] = 0.;
/* if required, generate u. */
if (! wantu) {
goto L300;
}
if (ncu < nctp1) {
goto L200;
}
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + j * u_dim1] = 0.;
/* L180: */
}
u[j + j * u_dim1] = 1.;
/* L190: */
}
L200:
if (nct < 1) {
goto L290;
}
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
l = nct - ll + 1;
if (s[l] == 0.) {
goto L250;
}
lp1 = l + 1;
if (ncu < lp1) {
goto L220;
}
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l + 1;
t = -ddot_(&i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1) / u[l + l * u_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/* L210: */
}
L220:
i__2 = *n - l + 1;
dscal_(&i__2, &c_b44, &u[l + l * u_dim1], &c__1);
u[l + l * u_dim1] += 1.;
lm1 = l - 1;
if (lm1 < 1) {
goto L240;
}
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L230: */
}
L240:
goto L270;
L250:
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L260: */
}
u[l + l * u_dim1] = 1.;
L270:
/* L280: */
;
}
L290:
L300:
/* if it is required, generate v. */
if (! wantv) {
goto L350;
}
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
l = *p - ll + 1;
lp1 = l + 1;
if (l > nrt) {
goto L320;
}
if (e[l] == 0.) {
goto L320;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *p - l;
t = -ddot_(&i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1) / v[lp1 + l * v_dim1];
i__3 = *p - l;
daxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/* L310: */
}
L320:
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = 0.;
/* L330: */
}
v[l + l * v_dim1] = 1.;
/* L340: */
}
L350:
/* main iteration loop for the singular values. */
mm = m;
iter = 0;
L360:
/* quit if all the singular values have been found. */
/* ...exit */
if (m == 0) {
goto L620;
}
/* if too many iterations have been performed, set */
/* flag and return. */
if (iter < maxit) {
goto L370;
}
*info = m;
/* ......exit */
goto L620;
L370:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
l = m - ll;
/* ...exit */
if (l == 0) {
goto L400;
}
test = (d__1 = s[l], abs(d__1)) + (d__2 = s[l + 1], abs(d__2));
ztest = test + (d__1 = e[l], abs(d__1));
if (ztest != test) {
goto L380;
}
e[l] = 0.;
/* ......exit */
goto L400;
L380:
/* L390: */
;
}
L400:
if (l != m - 1) {
goto L410;
}
kase = 4;
goto L480;
L410:
lp1 = l + 1;
mp1 = m + 1;
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
ls = m - lls + lp1;
/* ...exit */
if (ls == l) {
goto L440;
}
test = 0.;
if (ls != m) {
test += (d__1 = e[ls], abs(d__1));
}
if (ls != l + 1) {
test += (d__1 = e[ls - 1], abs(d__1));
}
ztest = test + (d__1 = s[ls], abs(d__1));
if (ztest != test) {
goto L420;
}
s[ls] = 0.;
/* ......exit */
goto L440;
L420:
/* L430: */
;
}
L440:
if (ls != l) {
goto L450;
}
kase = 3;
goto L470;
L450:
if (ls != m) {
goto L460;
}
kase = 1;
goto L470;
L460:
kase = 2;
l = ls;
L470:
L480:
++l;
/* perform the task indicated by kase. */
switch (kase) {
case 1: goto L490;
case 2: goto L520;
case 3: goto L540;
case 4: goto L570;
}
/* deflate negligible s(m). */
L490:
mm1 = m - 1;
f = e[m - 1];
e[m - 1] = 0.;
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
k = mm1 - kk + l;
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
if (k == l) {
goto L500;
}
f = -sn * e[k - 1];
e[k - 1] = cs * e[k - 1];
L500:
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/* L510: */
}
goto L610;
/* split at negligible s(l). */
L520:
f = e[l - 1];
e[l - 1] = 0.;
i__1 = m;
for (k = l; k <= i__1; ++k) {
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
f = -sn * e[k];
e[k] = cs * e[k];
if (wantu) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L530: */
}
goto L610;
/* perform one qr step. */
L540:
/* calculate the shift. */
/* Computing MAX */
d__6 = (d__1 = s[m], abs(d__1)), d__7 = (d__2 = s[m - 1], abs(d__2)),
d__6 = max(d__6,d__7), d__7 = (d__3 = e[m - 1], abs(d__3)), d__6 =
max(d__6,d__7), d__7 = (d__4 = s[l], abs(d__4)), d__6 = max(d__6,
d__7), d__7 = (d__5 = e[l], abs(d__5));
scale = max(d__6,d__7);
sm = s[m] / scale;
smm1 = s[m - 1] / scale;
emm1 = e[m - 1] / scale;
sl = s[l] / scale;
el = e[l] / scale;
/* Computing 2nd power */
d__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + d__1 * d__1) / 2.;
/* Computing 2nd power */
d__1 = sm * emm1;
c__ = d__1 * d__1;
shift = 0.;
if (b == 0. && c__ == 0.) {
goto L550;
}
/* Computing 2nd power */
d__1 = b;
shift = sqrt(d__1 * d__1 + c__);
if (b < 0.) {
shift = -shift;
}
shift = c__ / (b + shift);
L550:
f = (sl + sm) * (sl - sm) + shift;
g = sl * el;
/* chase zeros. */
mm1 = m - 1;
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
drotg_(&f, &g, &cs, &sn);
if (k != l) {
e[k - 1] = f;
}
f = cs * s[k] + sn * e[k];
e[k] = cs * e[k] - sn * s[k];
g = sn * s[k + 1];
s[k + 1] = cs * s[k + 1];
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
drotg_(&f, &g, &cs, &sn);
s[k] = f;
f = cs * e[k] + sn * s[k + 1];
s[k + 1] = -sn * e[k] + cs * s[k + 1];
g = sn * e[k + 1];
e[k + 1] = cs * e[k + 1];
if (wantu && k < *n) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L560: */
}
e[m - 1] = f;
++iter;
goto L610;
/* convergence. */
L570:
/* make the singular value positive. */
if (s[l] >= 0.) {
goto L580;
}
s[l] = -s[l];
if (wantv) {
dscal_(p, &c_b44, &v[l * v_dim1 + 1], &c__1);
}
L580:
/* order the singular value. */
L590:
if (l == mm) {
goto L600;
}
/* ...exit */
if (s[l] >= s[l + 1]) {
goto L600;
}
t = s[l];
s[l] = s[l + 1];
s[l + 1] = t;
if (wantv && l < *p) {
dswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
if (wantu && l < *n) {
dswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
++l;
goto L590;
L600:
iter = 0;
--m;
L610:
goto L360;
L620:
return 0;
} /* dsvdc_ */
/* DECK DBOLSM */
/* Subroutine */ int dbolsm_(doublereal *w, integer *mdw, integer *minput,
integer *ncols, doublereal *bl, doublereal *bu, integer *ind, integer
*iopt, doublereal *x, doublereal *rnorm, integer *mode, doublereal *
rw, doublereal *ww, doublereal *scl, integer *ibasis, integer *ibb)
{
/* System generated locals */
address a__1[3], a__2[4], a__3[6], a__4[5], a__5[2], a__6[7];
integer w_dim1, w_offset, i__1[3], i__2[4], i__3, i__4[6], i__5[5], i__6[
2], i__7[7], i__8, i__9, i__10;
doublereal d__1, d__2;
char ch__1[47], ch__2[50], ch__3[79], ch__4[53], ch__5[94], ch__6[75],
ch__7[83], ch__8[92], ch__9[105], ch__10[102], ch__11[61], ch__12[
110], ch__13[134], ch__14[44], ch__15[76];
/* Local variables */
static integer i__, j;
static doublereal t, t1, t2, sc;
static integer ip, jp, lp;
static doublereal ss, wt, cl1, cl2, cl3, fac, big;
static integer lds;
static doublereal bou, beta;
static integer jbig, jmag, ioff, jcol;
static doublereal wbig;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal wmag;
static integer mval, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal xnew;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static char xern1[8], xern2[8], xern3[16], xern4[16];
static doublereal alpha;
static logical found;
static integer nsetb;
extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
*, doublereal *), dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer igopr, itmax, itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer lgopr;
extern /* Subroutine */ int dmout_(integer *, integer *, integer *,
doublereal *, char *, integer *, ftnlen);
static integer jdrop;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int dvout_(integer *, doublereal *, char *,
integer *, ftnlen), ivout_(integer *, integer *, char *, integer *
, ftnlen);
static integer mrows, jdrop1, jdrop2, jlarge;
static doublereal colabv, colblo, wlarge, tolind;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static integer iprint;
static logical constr;
static doublereal tolsze;
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___9 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___12 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___14 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___15 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___16 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___17 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___18 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___31 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___32 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___33 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___34 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___35 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___36 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___37 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___38 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___39 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___40 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___41 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___42 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___43 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___44 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___45 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___54 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DBOLSM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBOCLS and DBOLS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SBOLSM-S, DBOLSM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* **** Double Precision Version of SBOLSM **** */
/* **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** */
/* Solve E*X = F (least squares sense) with bounds on */
/* selected X values. */
/* The user must have DIMENSION statements of the form: */
/* DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), */
/* * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) */
/* INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) */
/* (Here NX=number of extra locations required for options 1,...,7; */
/* NX=0 for no options; here NI=number of extra locations possibly */
/* required for options 1-7; NI=0 for no options; NI=14 if all the */
/* options are simultaneously in use.) */
/* INPUT */
/* ----- */
/* -------------------- */
/* W(MDW,*),MINPUT,NCOLS */
/* -------------------- */
/* The array W(*,*) contains the matrix [E:F] on entry. The matrix */
/* [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in */
/* the array W(*,*) with E occupying the first NCOLS columns and the */
/* right side vector F in column NCOLS+1. The row dimension, MDW, of */
/* the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. */
/* Other values of MDW are errors. The values of MINPUT and NCOLS */
/* must be positive. Other values are errors. */
/* ------------------ */
/* BL(*),BU(*),IND(*) */
/* ------------------ */
/* These arrays contain the information about the bounds that the */
/* solution values are to satisfy. The value of IND(J) tells the */
/* type of bound and BL(J) and BU(J) give the explicit values for */
/* the respective upper and lower bounds. */
/* 1. For IND(J)=1, require X(J) .ge. BL(J). */
/* 2. For IND(J)=2, require X(J) .le. BU(J). */
/* 3. For IND(J)=3, require X(J) .ge. BL(J) and */
/* X(J) .le. BU(J). */
/* 4. For IND(J)=4, no bounds on X(J) are required. */
/* The values of BL(*),BL(*) are modified by the subprogram. Values */
/* other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 */
/* (upper and lower bounds) the condition BL(J) .gt. BU(J) is an */
/* error. */
/* ------- */
/* IOPT(*) */
/* ------- */
/* This is the array where the user can specify nonstandard options */
/* for DBOLSM. Most of the time this feature can be ignored by */
/* setting the input value IOPT(1)=99. Occasionally users may have */
/* needs that require use of the following subprogram options. For */
/* details about how to use the options see below: IOPT(*) CONTENTS. */
/* Option Number Brief Statement of Purpose */
/* ----- ------ ----- --------- -- ------- */
/* 1 Move the IOPT(*) processing pointer. */
/* 2 Change rank determination tolerance. */
/* 3 Change blow-up factor that determines the */
/* size of variables being dropped from active */
/* status. */
/* 4 Reset the maximum number of iterations to use */
/* in solving the problem. */
/* 5 The data matrix is triangularized before the */
/* problem is solved whenever (NCOLS/MINPUT) .lt. */
/* FAC. Change the value of FAC. */
/* 6 Redefine the weighting matrix used for */
/* linear independence checking. */
/* 7 Debug output is desired. */
/* 99 No more options to change. */
/* ---- */
/* X(*) */
/* ---- */
/* This array is used to pass data associated with options 1,2,3 and */
/* 5. Ignore this input parameter if none of these options are used. */
/* Otherwise see below: IOPT(*) CONTENTS. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays must be initialized by the user. The values */
/* IBASIS(J)=J, J=1,...,NCOLS */
/* IBB(J) =1, J=1,...,NCOLS */
/* are appropriate except when using nonstandard features. */
/* ------ */
/* SCL(*) */
/* ------ */
/* This is the array of scaling factors to use on the columns of the */
/* matrix E. These values must be defined by the user. To suppress */
/* any column scaling set SCL(J)=1.0, J=1,...,NCOLS. */
/* OUTPUT */
/* ------ */
/* ---------- */
/* X(*),RNORM */
/* ---------- */
/* The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) */
/* for the constrained least squares problem. The value RNORM is the */
/* minimum residual vector length. */
/* ---- */
/* MODE */
/* ---- */
/* The sign of mode determines whether the subprogram has completed */
/* normally, or encountered an error condition or abnormal status. */
/* A value of MODE .ge. 0 signifies that the subprogram has completed */
/* normally. The value of MODE (.ge. 0) is the number of variables */
/* in an active status: not at a bound nor at the value ZERO, for */
/* the case of free variables. A negative value of MODE will be one */
/* of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond */
/* to an abnormal completion of the subprogram. To understand the */
/* abnormal completion codes see below: ERROR MESSAGES for DBOLSM */
/* An approximate solution will be returned to the user only when */
/* maximum iterations is reached, MODE=-22. */
/* ----------- */
/* RW(*),WW(*) */
/* ----------- */
/* These are working arrays each with NCOLS entries. The array RW(*) */
/* contains the working (scaled, nonactive) solution values. The */
/* array WW(*) contains the working (scaled, active) gradient vector */
/* values. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays contain information about the status of the solution */
/* when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the */
/* nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are */
/* the active variables. The value (IBB(J)-1) is the number of times */
/* variable J was reflected from its upper bound. (Normally the user */
/* can ignore these parameters.) */
/* IOPT(*) CONTENTS */
/* ------- -------- */
/* The option array allows a user to modify internal variables in */
/* the subprogram without recompiling the source code. A central */
/* goal of the initial software design was to do a good job for most */
/* people. Thus the use of options will be restricted to a select */
/* group of users. The processing of the option array proceeds as */
/* follows: a pointer, here called LP, is initially set to the value */
/* 1. The value is updated as the options are processed. At the */
/* pointer position the option number is extracted and used for */
/* locating other information that allows for options to be changed. */
/* The portion of the array IOPT(*) that is used for each option is */
/* fixed; the user and the subprogram both know how many locations */
/* are needed for each option. A great deal of error checking is */
/* done by the subprogram on the contents of the option array. */
/* Nevertheless it is still possible to give the subprogram optional */
/* input that is meaningless. For example, some of the options use */
/* the location X(NCOLS+IOFF) for passing data. The user must manage */
/* the allocation of these locations when more than one piece of */
/* option data is being passed to the subprogram. */
/* 1 */
/* - */
/* Move the processing pointer (either forward or backward) to the */
/* location IOPT(LP+1). The processing pointer is moved to location */
/* LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over */
/* locations 3,...,NCOLS+2 of IOPT(*), */
/* IOPT(1)=1 */
/* IOPT(2)=NCOLS+3 */
/* (IOPT(I), I=3,...,NCOLS+2 are not defined here.) */
/* IOPT(NCOLS+3)=99 */
/* CALL DBOLSM */
/* CAUTION: Misuse of this option can yield some very hard-to-find */
/* bugs. Use it with care. */
/* 2 */
/* - */
/* The algorithm that solves the bounded least squares problem */
/* iteratively drops columns from the active set. This has the */
/* effect of joining a new column vector to the QR factorization of */
/* the rectangular matrix consisting of the partially triangularized */
/* nonactive columns. After triangularizing this matrix a test is */
/* made on the size of the pivot element. The column vector is */
/* rejected as dependent if the magnitude of the pivot element is */
/* .le. TOL* magnitude of the column in components strictly above */
/* the pivot element. Nominally the value of this (rank) tolerance */
/* is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for */
/* example, */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=TOL */
/* IOPT(LP)=2 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 2 is */
/* used; The required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a */
/* warning message; it is not considered an error. */
/* 3 */
/* - */
/* A solution component is left active (not used) if, roughly */
/* speaking, it seems too large. Mathematically the new component is */
/* left active if the magnitude is .ge.((vector norm of F)/(matrix */
/* norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). */
/* To change only the value of BLOWUP, for example, */
/* X(NCOLS+2)=BLOWUP */
/* IOPT(1)=3 */
/* IOPT(2)=2 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=BLOWUP */
/* IOPT(LP)=3 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 3 is */
/* used; the required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. */
/* 4 */
/* - */
/* Normally the algorithm for solving the bounded least squares */
/* problem requires between NCOLS/3 and NCOLS drop-add steps to */
/* converge. (this remark is based on examining a small number of */
/* test cases.) The amount of arithmetic for such problems is */
/* typically about twice that required for linear least squares if */
/* there are no bounds and if plane rotations are used in the */
/* solution method. Convergence of the algorithm, while */
/* mathematically certain, can be much slower than indicated. To */
/* avoid this potential but unlikely event ITMAX drop-add steps are */
/* permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the */
/* value of ITMAX, for example, */
/* IOPT(1)=4 */
/* IOPT(2)=ITMAX */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* IOPT(LP)=4 */
/* IOPT(LP+1)=ITMAX */
/* . */
/* CALL DBOLSM */
/* The value of ITMAX must be .gt. 0. Other values are errors. Use */
/* of this option increases the required length of IOPT(*) by 2. */
/* 5 */
/* - */
/* For purposes of increased efficiency the MINPUT by NCOLS+1 data */
/* matrix [E:F] is triangularized as a first step whenever MINPUT */
/* satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the */
/* value of FAC, */
/* X(NCOLS+3)=FAC */
/* IOPT(1)=5 */
/* IOPT(2)=3 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=FAC */
/* IOPT(LP)=5 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The value of FAC must be nonnegative. Other values are errors. */
/* Resetting FAC=0.0 suppresses the initial triangularization step. */
/* Use of this option increases the required length of IOPT(*) by 2; */
/* The required length of of X(*) is increased by 1. */
/* 6 */
/* - */
/* The norm used in testing the magnitudes of the pivot element */
/* compared to the mass of the column above the pivot line can be */
/* changed. The type of change that this option allows is to weight */
/* the components with an index larger than MVAL by the parameter */
/* WT. Normally MVAL=0 and WT=1. To change both the values MVAL and */
/* WT, where LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=WT */
/* IOPT(LP)=6 */
/* IOPT(LP+1)=IOFF */
/* IOPT(LP+2)=MVAL */
/* Use of this option increases the required length of IOPT(*) by 3. */
/* The length of X(*) is increased by 1. Values of MVAL must be */
/* nonnegative and not greater than MINPUT. Other values are errors. */
/* The value of WT must be positive. Any other value is an error. If */
/* either error condition is present a message will be printed. */
/* 7 */
/* - */
/* Debug output, showing the detailed add-drop steps for the */
/* constrained least squares problem, is desired. This option is */
/* intended to be used to locate suspected bugs. */
/* 99 */
/* -- */
/* There are no more options to change. */
/* The values for options are 1,...,7,99, and are the only ones */
/* permitted. Other values are errors. Options -99,-1,...,-7 mean */
/* that the repective options 99,1,...,7 are left at their default */
/* values. An example is the option to modify the (rank) tolerance: */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=-2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* Error Messages for DBOLSM */
/* ----- -------- --- --------- */
/* -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST */
/* SQUARES PROBLEM. */
/* -23 THE OPTION NUMBER = ... IS NOT DEFINED. */
/* -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE */
/* FOR OPTION NUMBER 2. */
/* -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN */
/* MACHINE PRECISION = .... */
/* -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 3. */
/* -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES */
/* MUST BE POSITIVE. NOW = .... */
/* -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. */
/* -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 5. */
/* -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS */
/* PERFORMED MUST BE NONNEGATIVE. NOW = .... */
/* -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. */
/* -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. */
/* -33 THE ROW DIMENSION OF W(,) = ... MUST BE .GE. THE NUMBER OF */
/* ROWS = .... */
/* -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. */
/* -35 FOR J = ... THE LOWER BOUND = ... IS .GT. THE UPPER BOUND = */
/* .... */
/* -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS */
/* = .... */
/* -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE */
/* POSITIVE. NOW = .... */
/* -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN */
/* 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. */
/* ***SEE ALSO DBOCLS, DBOLS */
/* ***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DMOUT, DNRM2, DROT, */
/* DROTG, DSWAP, DVOUT, IVOUT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 821220 DATE WRITTEN */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920422 Fixed usage of MINPUT. (WRB) */
/* 901009 Editorial changes, code now reads from top to bottom. (RWC) */
/* ***END PROLOGUE DBOLSM */
/* PURPOSE */
/* ------- */
/* THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED */
/* LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: */
/* SOLVE E*X = F (LEAST SQUARES SENSE) */
/* WITH BOUNDS ON SELECTED X VALUES. */
/* TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN */
/* EDITING AT THE CARD 'C++'. */
/* CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS */
/* /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, */
/* /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, */
/* /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, */
/* /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, */
/* /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, */
/* /REAL / TO /DOUBLE PRECISION/. */
/* ++ */
/* ***FIRST EXECUTABLE STATEMENT DBOLSM */
/* Verify that the problem dimensions are defined properly. */
/* Parameter adjustments */
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
--bl;
--bu;
--ind;
--iopt;
--x;
--rw;
--ww;
--scl;
--ibasis;
--ibb;
/* Function Body */
if (*minput <= 0) {
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 21, a__1[0] = "THE NUMBER OF ROWS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)47);
xermsg_("SLATEC", "DBOLSM", ch__1, &c__31, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)47);
*mode = -31;
return 0;
}
if (*ncols <= 0) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 24, a__1[0] = "THE NUMBER OF COLUMNS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)50);
xermsg_("SLATEC", "DBOLSM", ch__2, &c__32, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)50);
*mode = -32;
return 0;
}
if (*mdw < *minput) {
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*mdw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 28, a__2[0] = "THE ROW DIMENSION OF W(,) = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 35, a__2[2] = " MUST BE .GE. THE NUMBER OF ROWS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__3, a__2, i__2, &c__4, (ftnlen)79);
xermsg_("SLATEC", "DBOLSM", ch__3, &c__33, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)79);
*mode = -33;
return 0;
}
/* Verify that bound information is correct. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] < 1 || ind[j] > 4) {
s_wsfi(&io___8);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___9);
do_fio(&c__1, (char *)&ind[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 8, a__1[0] = "FOR J = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 37, a__1[2] = " THE CONSTRAINT INDICATOR MUST BE 1-4";
s_cat(ch__4, a__1, i__1, &c__3, (ftnlen)53);
xermsg_("SLATEC", "DBOLSM", ch__4, &c__34, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)53);
*mode = -34;
return 0;
}
/* L10: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 3) {
if (bu[j] < bl[j]) {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___12);
do_fio(&c__1, (char *)&bl[j], (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___14);
do_fio(&c__1, (char *)&bu[j], (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__4[0] = 8, a__3[0] = "FOR J = ";
i__4[1] = 8, a__3[1] = xern1;
i__4[2] = 19, a__3[2] = " THE LOWER BOUND = ";
i__4[3] = 16, a__3[3] = xern3;
i__4[4] = 27, a__3[4] = " IS .GT. THE UPPER BOUND = ";
i__4[5] = 16, a__3[5] = xern4;
s_cat(ch__5, a__3, i__4, &c__6, (ftnlen)94);
xermsg_("SLATEC", "DBOLSM", ch__5, &c__35, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)94);
*mode = -35;
return 0;
}
}
/* L20: */
}
/* Check that permutation and polarity arrays have been set. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibasis[j] < 1 || ibasis[j] > *ncols) {
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ibasis[j], (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___16);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 29, a__2[0] = "THE INPUT ORDER OF COLUMNS = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 30, a__2[2] = " IS NOT BETWEEN 1 AND NCOLS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__6, a__2, i__2, &c__4, (ftnlen)75);
xermsg_("SLATEC", "DBOLSM", ch__6, &c__36, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)75);
*mode = -36;
return 0;
}
if (ibb[j] <= 0) {
s_wsfi(&io___17);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ibb[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 41, a__2[0] = "THE BOUND POLARITY FLAG IN COMPONENT J "
"= ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 26, a__2[2] = " MUST BE POSITIVE.$$NOW = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__7, a__2, i__2, &c__4, (ftnlen)83);
xermsg_("SLATEC", "DBOLSM", ch__7, &c__37, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)83);
*mode = -37;
return 0;
}
/* L30: */
}
/* Process the option array. */
fac = .75;
tolind = sqrt(d1mach_(&c__4));
tolsze = sqrt(d1mach_(&c__4));
itmax = max(*minput,*ncols) * 5;
wt = 1.;
mval = 0;
iprint = 0;
/* Changes to some parameters can occur through the option array, */
/* IOPT(*). Process this array looking carefully for input data */
/* errors. */
lp = 0;
lds = 0;
/* Test for no more options. */
L590:
lp += lds;
ip = iopt[lp + 1];
jp = abs(ip);
if (ip == 99) {
goto L470;
} else if (jp == 99) {
lds = 1;
} else if (jp == 1) {
/* Move the IOPT(*) processing pointer. */
if (ip > 0) {
lp = iopt[lp + 2] - 1;
lds = 0;
} else {
lds = 2;
}
} else if (jp == 2) {
/* Change tolerance for rank determination. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___31);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___32);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 2.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__24, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -24;
return 0;
}
tolind = x[*ncols + ioff];
if (tolind < d1mach_(&c__4)) {
s_wsfi(&io___33);
do_fio(&c__1, (char *)&tolind, (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___34);
d__1 = d1mach_(&c__4);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__2[0] = "THE TOLERANCE FOR RANK DETERMINATIO"
"N = ";
i__2[1] = 16, a__2[1] = xern3;
i__2[2] = 34, a__2[2] = " IS LESS THAN MACHINE PRECISION = ";
i__2[3] = 16, a__2[3] = xern4;
s_cat(ch__9, a__2, i__2, &c__4, (ftnlen)105);
xermsg_("SLATEC", "DBOLSM", ch__9, &c__25, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)105);
*mode = -25;
}
}
lds = 2;
} else if (jp == 3) {
/* Change blowup factor for allowing variables to become */
/* inactive. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___35);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___36);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 3.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__26, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -26;
return 0;
}
tolsze = x[*ncols + ioff];
if (tolsze <= 0.) {
s_wsfi(&io___37);
do_fio(&c__1, (char *)&tolsze, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 86, a__5[0] = "THE RECIPROCAL OF THE BLOW-UP FACTO"
"R FOR REJECTING VARIABLES MUST BE POSITIVE.$$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__10, a__5, i__6, &c__2, (ftnlen)102);
xermsg_("SLATEC", "DBOLSM", ch__10, &c__27, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)102);
*mode = -27;
return 0;
}
}
lds = 2;
} else if (jp == 4) {
/* Change the maximum number of iterations allowed. */
if (ip > 0) {
itmax = iopt[lp + 2];
if (itmax <= 0) {
s_wsfi(&io___38);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 35, a__1[0] = "THE MAXIMUM NUMBER OF ITERATIONS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__11, a__1, i__1, &c__3, (ftnlen)61);
xermsg_("SLATEC", "DBOLSM", ch__11, &c__28, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)61);
*mode = -28;
return 0;
}
}
lds = 2;
} else if (jp == 5) {
/* Change the factor for pretriangularizing the data matrix. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___39);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___40);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 5.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__29, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -29;
return 0;
}
fac = x[*ncols + ioff];
if (fac < 0.) {
s_wsfi(&io___41);
do_fio(&c__1, (char *)&fac, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 94, a__5[0] = "THE FACTOR (NCOLS/MINPUT) WHERE PRE"
"-TRIANGULARIZING IS PERFORMED MUST BE NON-NEGATIVE.$"
"$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__12, a__5, i__6, &c__2, (ftnlen)110);
xermsg_("SLATEC", "DBOLSM", ch__12, &c__30, &c__0, (ftnlen)6,
(ftnlen)6, (ftnlen)110);
*mode = -30;
return 0;
}
}
lds = 2;
} else if (jp == 6) {
/* Change the weighting factor (from 1.0) to apply to components */
/* numbered .gt. MVAL (initially set to 1.) This trick is needed */
/* for applications of this subprogram to the heavily weighted */
/* least squares problem that come from equality constraints. */
if (ip > 0) {
ioff = iopt[lp + 2];
mval = iopt[lp + 3];
wt = x[*ncols + ioff];
}
if (mval < 0 || mval > *minput || wt <= 0.) {
s_wsfi(&io___42);
do_fio(&c__1, (char *)&mval, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___43);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___44);
do_fio(&c__1, (char *)&wt, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__7[0] = 38, a__6[0] = "THE ROW SEPARATOR TO APPLY WEIGHTING (";
i__7[1] = 8, a__6[1] = xern1;
i__7[2] = 34, a__6[2] = ") MUST LIE BETWEEN 0 AND MINPUT = ";
i__7[3] = 8, a__6[3] = xern2;
i__7[4] = 12, a__6[4] = ".$$WEIGHT = ";
i__7[5] = 16, a__6[5] = xern3;
i__7[6] = 18, a__6[6] = " MUST BE POSITIVE.";
s_cat(ch__13, a__6, i__7, &c__7, (ftnlen)134);
xermsg_("SLATEC", "DBOLSM", ch__13, &c__38, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)134);
*mode = -38;
return 0;
}
lds = 3;
} else if (jp == 7) {
/* Turn on debug output. */
if (ip > 0) {
iprint = 1;
}
lds = 2;
} else {
s_wsfi(&io___45);
do_fio(&c__1, (char *)&ip, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 20, a__1[0] = "THE OPTION NUMBER = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 16, a__1[2] = " IS NOT DEFINED.";
s_cat(ch__14, a__1, i__1, &c__3, (ftnlen)44);
xermsg_("SLATEC", "DBOLSM", ch__14, &c__23, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)44);
*mode = -23;
return 0;
}
goto L590;
/* Pretriangularize rectangular arrays of certain sizes for */
/* increased efficiency. */
L470:
if (fac * *minput > (doublereal) (*ncols)) {
i__3 = *ncols + 1;
for (j = 1; j <= i__3; ++j) {
i__8 = j + mval + 1;
for (i__ = *minput; i__ >= i__8; --i__) {
drotg_(&w[i__ - 1 + j * w_dim1], &w[i__ + j * w_dim1], &sc, &
ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[i__ - 1 + (j + 1) * w_dim1], mdw, &w[i__ + (j
+ 1) * w_dim1], mdw, &sc, &ss);
/* L480: */
}
/* L490: */
}
mrows = *ncols + mval + 1;
} else {
mrows = *minput;
}
/* Set the X(*) array to zero so all components are defined. */
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
/* The arrays IBASIS(*) and IBB(*) are initialized by the calling */
/* program and the column scaling is defined in the calling program. */
/* 'BIG' is plus infinity on this machine. */
big = d1mach_(&c__2);
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 1) {
bu[j] = big;
} else if (ind[j] == 2) {
bl[j] = -big;
} else if (ind[j] == 4) {
bl[j] = -big;
bu[j] = big;
}
/* L550: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (bl[j] <= 0. && 0. <= bu[j] && (d__1 = bu[j], abs(d__1)) < (d__2 =
bl[j], abs(d__2)) || bu[j] < 0.) {
t = bu[j];
bu[j] = -bl[j];
bl[j] = -t;
scl[j] = -scl[j];
i__8 = mrows;
for (i__ = 1; i__ <= i__8; ++i__) {
w[i__ + j * w_dim1] = -w[i__ + j * w_dim1];
/* L560: */
}
}
/* Indices in set T(=TIGHT) are denoted by negative values */
/* of IBASIS(*). */
if (bl[j] >= 0.) {
ibasis[j] = -ibasis[j];
t = -bl[j];
bu[j] += t;
daxpy_(&mrows, &t, &w[j * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
}
/* L570: */
}
nsetb = 0;
iter = 0;
if (iprint > 0) {
i__3 = *ncols + 1;
dmout_(&mrows, &i__3, mdw, &w[w_offset], "(' PRETRI. INPUT MATRIX')",
&c_n4, (ftnlen)25);
dvout_(ncols, &bl[1], "(' LOWER BOUNDS')", &c_n4, (ftnlen)17);
dvout_(ncols, &bu[1], "(' UPPER BOUNDS')", &c_n4, (ftnlen)17);
}
L580:
++iter;
if (iter > itmax) {
s_wsfi(&io___54);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 18, a__1[0] = "MORE THAN ITMAX = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 50, a__1[2] = " ITERATIONS SOLVING BOUNDED LEAST SQUARES P"
"ROBLEM.";
s_cat(ch__15, a__1, i__1, &c__3, (ftnlen)76);
xermsg_("SLATEC", "DBOLSM", ch__15, &c__22, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)76);
*mode = -22;
/* Rescale and translate variables. */
igopr = 1;
goto L130;
}
/* Find a variable to become non-active. */
/* T */
/* Compute (negative) of gradient vector, W = E *(F-E*X). */
dcopy_(ncols, &c_b185, &c__0, &ww[1], &c__1);
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
i__8 = mrows - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
/* Computing MIN */
i__10 = nsetb + 1;
ww[j] = ddot_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1, &w[min(
i__10,mrows) + (*ncols + 1) * w_dim1], &c__1) * (d__1 = scl[
jcol], abs(d__1));
/* L200: */
}
if (iprint > 0) {
dvout_(ncols, &ww[1], "(' GRADIENT VALUES')", &c_n4, (ftnlen)20);
ivout_(ncols, &ibasis[1], "(' INTERNAL VARIABLE ORDER')", &c_n4, (
ftnlen)28);
ivout_(ncols, &ibb[1], "(' BOUND POLARITY')", &c_n4, (ftnlen)19);
}
/* If active set = number of total rows, quit. */
L210:
if (nsetb == mrows) {
found = FALSE_;
goto L120;
}
/* Choose an extremal component of gradient vector for a candidate */
/* to become non-active. */
wlarge = -big;
wmag = -big;
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
t = ww[j];
if (t == big) {
goto L220;
}
itemp = ibasis[j];
jcol = abs(itemp);
i__8 = mval - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
t1 = dnrm2_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1);
if (itemp < 0) {
if (ibb[jcol] % 2 == 0) {
t = -t;
}
if (t < 0.) {
goto L220;
}
if (mval > nsetb) {
t = t1;
}
if (t > wlarge) {
wlarge = t;
jlarge = j;
}
} else {
if (mval > nsetb) {
t = t1;
}
if (abs(t) > wmag) {
wmag = abs(t);
jmag = j;
}
}
L220:
;
}
/* Choose magnitude of largest component of gradient for candidate. */
jbig = 0;
wbig = 0.;
if (wlarge > 0.) {
jbig = jlarge;
wbig = wlarge;
}
if (wmag >= wbig) {
jbig = jmag;
wbig = wmag;
}
if (jbig == 0) {
found = FALSE_;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' FOUND NO VARIABLE TO ENTER')", &c_n4, (
ftnlen)31);
}
goto L120;
}
/* See if the incoming column is sufficiently independent. This */
/* test is made before an elimination is performed. */
if (iprint > 0) {
ivout_(&c__1, &jbig, "(' TRY TO BRING IN THIS COL.')", &c_n4, (ftnlen)
30);
}
if (mval <= nsetb) {
cl1 = dnrm2_(&mval, &w[jbig * w_dim1 + 1], &c__1);
i__3 = nsetb - mval;
/* Computing MIN */
i__8 = mval + 1;
cl2 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
i__3 = mrows - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
drotg_(&cl1, &cl2, &sc, &ss);
colabv = abs(cl1);
colblo = cl3;
} else {
cl1 = dnrm2_(&nsetb, &w[jbig * w_dim1 + 1], &c__1);
i__3 = mval - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl2 = dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &c__1);
i__3 = mrows - mval;
/* Computing MIN */
i__8 = mval + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
colabv = cl1;
drotg_(&cl2, &cl3, &sc, &ss);
colblo = abs(cl2);
}
if (colblo <= tolind * colabv) {
ww[jbig] = big;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE IS DEPENDENT, NOT USED.')", &
c_n4, (ftnlen)37);
}
goto L210;
}
/* Swap matrix columns NSETB+1 and JBIG, plus pointer information, */
/* and gradient values. */
++nsetb;
if (nsetb != jbig) {
dswap_(&mrows, &w[nsetb * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &
c__1);
dswap_(&c__1, &ww[nsetb], &c__1, &ww[jbig], &c__1);
itemp = ibasis[nsetb];
ibasis[nsetb] = ibasis[jbig];
ibasis[jbig] = itemp;
}
/* Eliminate entries below the pivot line in column NSETB. */
if (mrows > nsetb) {
i__3 = nsetb + 1;
for (i__ = mrows; i__ >= i__3; --i__) {
if (i__ == mval + 1) {
goto L230;
}
drotg_(&w[i__ - 1 + nsetb * w_dim1], &w[i__ + nsetb * w_dim1], &
sc, &ss);
w[i__ + nsetb * w_dim1] = 0.;
i__8 = *ncols - nsetb + 1;
drot_(&i__8, &w[i__ - 1 + (nsetb + 1) * w_dim1], mdw, &w[i__ + (
nsetb + 1) * w_dim1], mdw, &sc, &ss);
L230:
;
}
if (mval >= nsetb && mval < mrows) {
drotg_(&w[nsetb + nsetb * w_dim1], &w[mval + 1 + nsetb * w_dim1],
&sc, &ss);
w[mval + 1 + nsetb * w_dim1] = 0.;
i__3 = *ncols - nsetb + 1;
drot_(&i__3, &w[nsetb + (nsetb + 1) * w_dim1], mdw, &w[mval + 1 +
(nsetb + 1) * w_dim1], mdw, &sc, &ss);
}
}
if (w[nsetb + nsetb * w_dim1] == 0.) {
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' PIVOT IS ZERO, NOT USED.')", &c_n4, (
ftnlen)29);
}
goto L210;
}
/* Check that new variable is moving in the right direction. */
itemp = ibasis[nsetb];
jcol = abs(itemp);
xnew = w[nsetb + (*ncols + 1) * w_dim1] / w[nsetb + nsetb * w_dim1] / (
d__1 = scl[jcol], abs(d__1));
if (itemp < 0) {
/* IF(WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) exit(quit) */
/* IF(WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) exit(quit) */
if (ww[nsetb] >= 0. && xnew <= 0. || ww[nsetb] <= 0. && xnew >= 0.) {
goto L240;
}
}
found = TRUE_;
goto L120;
L240:
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE HAS BAD DIRECTION, NOT USED.')", &
c_n4, (ftnlen)42);
}
goto L210;
/* Solve the triangular system. */
L270:
dcopy_(&nsetb, &w[(*ncols + 1) * w_dim1 + 1], &c__1, &rw[1], &c__1);
for (j = nsetb; j >= 1; --j) {
rw[j] /= w[j + j * w_dim1];
jcol = (i__3 = ibasis[j], abs(i__3));
t = rw[j];
if (ibb[jcol] % 2 == 0) {
rw[j] = -rw[j];
}
i__3 = j - 1;
d__1 = -t;
daxpy_(&i__3, &d__1, &w[j * w_dim1 + 1], &c__1, &rw[1], &c__1);
rw[j] /= (d__1 = scl[jcol], abs(d__1));
/* L280: */
}
if (iprint > 0) {
dvout_(&nsetb, &rw[1], "(' SOLN. VALUES')", &c_n4, (ftnlen)17);
ivout_(&nsetb, &ibasis[1], "(' COLS. USED')", &c_n4, (ftnlen)15);
}
if (lgopr == 2) {
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] <= bou) {
jdrop1 = j;
goto L340;
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] >= bou) {
jdrop2 = j;
goto L340;
}
/* L450: */
}
goto L340;
}
/* See if the unconstrained solution (obtained by solving the */
/* triangular system) satisfies the problem bounds. */
alpha = 2.;
beta = 2.;
x[nsetb] = 0.;
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
t1 = 2.;
t2 = 2.;
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] <= bou) {
t1 = (x[j] - bou) / (x[j] - rw[j]);
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] >= bou) {
t2 = (bou - x[j]) / (rw[j] - x[j]);
}
/* If not, then compute a step length so that the variables remain */
/* feasible. */
if (t1 < alpha) {
alpha = t1;
jdrop1 = j;
}
if (t2 < beta) {
beta = t2;
jdrop2 = j;
}
/* L310: */
}
constr = alpha < 2. || beta < 2.;
if (! constr) {
/* Accept the candidate because it satisfies the stated bounds */
/* on the variables. */
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
goto L580;
}
/* Take a step that is as large as possible with all variables */
/* remaining feasible. */
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
x[j] += min(alpha,beta) * (rw[j] - x[j]);
/* L330: */
}
if (alpha <= beta) {
jdrop2 = 0;
} else {
jdrop1 = 0;
}
L340:
if (jdrop1 + jdrop2 <= 0 || nsetb <= 0) {
goto L580;
}
/* L350: */
jdrop = jdrop1 + jdrop2;
itemp = ibasis[jdrop];
jcol = abs(itemp);
if (jdrop2 > 0) {
/* Variable is at an upper bound. Subtract multiple of this */
/* column from right hand side. */
t = bu[jcol];
if (itemp > 0) {
bu[jcol] = t - bl[jcol];
bl[jcol] = -t;
itemp = -itemp;
scl[jcol] = -scl[jcol];
i__3 = jdrop;
for (i__ = 1; i__ <= i__3; ++i__) {
w[i__ + jdrop * w_dim1] = -w[i__ + jdrop * w_dim1];
/* L360: */
}
} else {
++ibb[jcol];
if (ibb[jcol] % 2 == 0) {
t = -t;
}
}
/* Variable is at a lower bound. */
} else {
if ((doublereal) itemp < 0.) {
t = 0.;
} else {
t = -bl[jcol];
bu[jcol] += t;
itemp = -itemp;
}
}
daxpy_(&jdrop, &t, &w[jdrop * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
/* Move certain columns left to achieve upper Hessenberg form. */
dcopy_(&jdrop, &w[jdrop * w_dim1 + 1], &c__1, &rw[1], &c__1);
i__3 = nsetb;
for (j = jdrop + 1; j <= i__3; ++j) {
ibasis[j - 1] = ibasis[j];
x[j - 1] = x[j];
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[(j - 1) * w_dim1 + 1], &c__1)
;
/* L370: */
}
ibasis[nsetb] = itemp;
w[nsetb * w_dim1 + 1] = 0.;
i__3 = mrows - jdrop;
dcopy_(&i__3, &w[nsetb * w_dim1 + 1], &c__0, &w[jdrop + 1 + nsetb *
w_dim1], &c__1);
dcopy_(&jdrop, &rw[1], &c__1, &w[nsetb * w_dim1 + 1], &c__1);
/* Transform the matrix from upper Hessenberg form to upper */
/* triangular form. */
--nsetb;
i__3 = nsetb;
for (i__ = jdrop; i__ <= i__3; ++i__) {
/* Look for small pivots and avoid mixing weighted and */
/* nonweighted rows. */
if (i__ == mval) {
t = 0.;
i__8 = nsetb;
for (j = i__; j <= i__8; ++j) {
jcol = (i__9 = ibasis[j], abs(i__9));
t1 = (d__1 = w[i__ + j * w_dim1] * scl[jcol], abs(d__1));
if (t1 > t) {
jbig = j;
t = t1;
}
/* L380: */
}
goto L400;
}
drotg_(&w[i__ + i__ * w_dim1], &w[i__ + 1 + i__ * w_dim1], &sc, &ss);
w[i__ + 1 + i__ * w_dim1] = 0.;
i__8 = *ncols - i__ + 1;
drot_(&i__8, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + (i__ + 1)
* w_dim1], mdw, &sc, &ss);
/* L390: */
}
goto L430;
/* The triangularization is completed by giving up the Hessenberg */
/* form and triangularizing a rectangular matrix. */
L400:
dswap_(&mrows, &w[i__ * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &c__1);
dswap_(&c__1, &ww[i__], &c__1, &ww[jbig], &c__1);
dswap_(&c__1, &x[i__], &c__1, &x[jbig], &c__1);
itemp = ibasis[i__];
ibasis[i__] = ibasis[jbig];
ibasis[jbig] = itemp;
jbig = i__;
i__3 = nsetb;
for (j = jbig; j <= i__3; ++j) {
i__8 = mrows;
for (i__ = j + 1; i__ <= i__8; ++i__) {
drotg_(&w[j + j * w_dim1], &w[i__ + j * w_dim1], &sc, &ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[j + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) *
w_dim1], mdw, &sc, &ss);
/* L410: */
}
/* L420: */
}
/* See if the remaining coefficients are feasible. They should be */
/* because of the way MIN(ALPHA,BETA) was chosen. Any that are not */
/* feasible will be set to their bounds and appropriately translated. */
L430:
jdrop1 = 0;
jdrop2 = 0;
lgopr = 2;
goto L270;
/* Find a variable to become non-active. */
L120:
if (found) {
lgopr = 1;
goto L270;
}
/* Rescale and translate variables. */
igopr = 2;
L130:
dcopy_(&nsetb, &x[1], &c__1, &rw[1], &c__1);
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
x[jcol] = rw[j] * (d__1 = scl[jcol], abs(d__1));
/* L140: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibb[j] % 2 == 0) {
x[j] = bu[j] - x[j];
}
/* L150: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
jcol = ibasis[j];
if (jcol < 0) {
x[-jcol] = bl[-jcol] + x[-jcol];
}
/* L160: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (scl[j] < 0.) {
x[j] = -x[j];
}
/* L170: */
}
i__ = max(nsetb,mval);
i__3 = mrows - i__;
/* Computing MIN */
i__8 = i__ + 1;
*rnorm = dnrm2_(&i__3, &w[min(i__8,mrows) + (*ncols + 1) * w_dim1], &c__1)
;
if (igopr == 2) {
*mode = nsetb;
}
return 0;
} /* dbolsm_ */
void drotg(double *A, double *B, double *C, double *S)
{
drotg_(A, B, C, S);
}
GURLS_EXPORT void rotg(double *a, double *b, double *c, double *s)
{
drotg_(a, b, c, s);
}
void cblas_drotg( double *a, double *b, double *c, double *s)
{
drotg_(a,b,c,s);
}
/*< subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) >*/
/* Subroutine */ int dsvdc_(doublereal *x, integer *ldx, integer *n, integer *
p, doublereal *s, doublereal *e, doublereal *u, integer *ldu,
doublereal *v, integer *ldv, doublereal *work, integer *job, integer *
info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l=0, m;
doublereal t, t1, el;
integer kk;
doublereal cs;
integer ll, mm, ls=0;
doublereal sl;
integer lu;
doublereal sm, sn;
integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
doublereal emm1, smm1;
integer kase;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer jobu, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal test;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
integer nctp1, nrtp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal scale, shift;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), drotg_(doublereal *, doublereal *,
doublereal *, doublereal *);
integer maxit;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
logical wantu, wantv;
doublereal ztest;
/*< integer ldx,n,p,ldu,ldv,job,info >*/
/*< double precision x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1) >*/
/* dsvdc is a subroutine to reduce a double precision nxp matrix x */
/* by orthogonal transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x double precision(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by dsvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u. */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v. */
/* (see below). */
/* work double precision(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 return the first min(n,p) singular */
/* vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s double precision(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e double precision(p), */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u double precision(ldu,k), where ldu.ge.n. if */
/* joba.eq.1 then k.eq.n, if joba.ge.2 */
/* then k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.eq.2, then u may be identified with x */
/* in the subroutine call. */
/* v double precision(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if job.eq.0. if p.le.n, */
/* then v may be identified with x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = trans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (trans(u) */
/* is the transpose of u). thus the singular */
/* values of x and b are the same. */
/* linpack. this version dated 08/14/78 . */
/* correction made to shift 2/84. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* dsvdc uses the following functions and subprograms. */
/* external drot */
/* blas daxpy,ddot,dscal,dswap,dnrm2,drotg */
/* fortran dabs,dmax1,max0,min0,mod,dsqrt */
/* internal variables */
/*< >*/
/*< double precision ddot,t,r >*/
/*< >*/
/*< logical wantu,wantv >*/
/* set the maximum number of iterations. */
/*< maxit = 1000 >*/
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 1000;
/* determine what is to be computed. */
/*< wantu = .false. >*/
wantu = FALSE_;
/*< wantv = .false. >*/
wantv = FALSE_;
/*< jobu = mod(job,100)/10 >*/
jobu = *job % 100 / 10;
/*< ncu = n >*/
ncu = *n;
/*< if (jobu .gt. 1) ncu = min0(n,p) >*/
if (jobu > 1) {
ncu = min(*n,*p);
}
/*< if (jobu .ne. 0) wantu = .true. >*/
if (jobu != 0) {
wantu = TRUE_;
}
/*< if (mod(job,10) .ne. 0) wantv = .true. >*/
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
/*< info = 0 >*/
*info = 0;
/*< nct = min0(n-1,p) >*/
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/*< nrt = max0(0,min0(p-2,n)) >*/
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
/*< lu = max0(nct,nrt) >*/
lu = max(nct,nrt);
/*< if (lu .lt. 1) go to 170 >*/
if (lu < 1) {
goto L170;
}
/*< do 160 l = 1, lu >*/
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nct) go to 20 >*/
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
/*< s(l) = dnrm2(n-l+1,x(l,l),1) >*/
i__2 = *n - l + 1;
s[l] = dnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
/*< if (s(l) .eq. 0.0d0) go to 10 >*/
if (s[l] == 0.) {
goto L10;
}
/*< if (x(l,l) .ne. 0.0d0) s(l) = dsign(s(l),x(l,l)) >*/
if (x[l + l * x_dim1] != 0.) {
s[l] = d_sign(&s[l], &x[l + l * x_dim1]);
}
/*< call dscal(n-l+1,1.0d0/s(l),x(l,l),1) >*/
i__2 = *n - l + 1;
d__1 = 1. / s[l];
dscal_(&i__2, &d__1, &x[l + l * x_dim1], &c__1);
/*< x(l,l) = 1.0d0 + x(l,l) >*/
x[l + l * x_dim1] += 1.;
/*< 10 continue >*/
L10:
/*< s(l) = -s(l) >*/
s[l] = -s[l];
/*< 20 continue >*/
L20:
/*< if (p .lt. lp1) go to 50 >*/
if (*p < lp1) {
goto L50;
}
/*< do 40 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< if (l .gt. nct) go to 30 >*/
if (l > nct) {
goto L30;
}
/*< if (s(l) .eq. 0.0d0) go to 30 >*/
if (s[l] == 0.) {
goto L30;
}
/* apply the transformation. */
/*< t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) >*/
i__3 = *n - l + 1;
t = -ddot_(&i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1) / x[l + l * x_dim1];
/*< call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) >*/
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
/*< 30 continue >*/
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
/*< e(j) = x(l,j) >*/
e[j] = x[l + j * x_dim1];
/*< 40 continue >*/
/* L40: */
}
/*< 50 continue >*/
L50:
/*< if (.not.wantu .or. l .gt. nct) go to 70 >*/
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
/*< do 60 i = l, n >*/
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
/*< u(i,l) = x(i,l) >*/
u[i__ + l * u_dim1] = x[i__ + l * x_dim1];
/*< 60 continue >*/
/* L60: */
}
/*< 70 continue >*/
L70:
/*< if (l .gt. nrt) go to 150 >*/
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
/*< e(l) = dnrm2(p-l,e(lp1),1) >*/
i__2 = *p - l;
e[l] = dnrm2_(&i__2, &e[lp1], &c__1);
/*< if (e(l) .eq. 0.0d0) go to 80 >*/
if (e[l] == 0.) {
goto L80;
}
/*< if (e(lp1) .ne. 0.0d0) e(l) = dsign(e(l),e(lp1)) >*/
if (e[lp1] != 0.) {
e[l] = d_sign(&e[l], &e[lp1]);
}
/*< call dscal(p-l,1.0d0/e(l),e(lp1),1) >*/
i__2 = *p - l;
d__1 = 1. / e[l];
dscal_(&i__2, &d__1, &e[lp1], &c__1);
/*< e(lp1) = 1.0d0 + e(lp1) >*/
e[lp1] += 1.;
/*< 80 continue >*/
L80:
/*< e(l) = -e(l) >*/
e[l] = -e[l];
/*< if (lp1 .gt. n .or. e(l) .eq. 0.0d0) go to 120 >*/
if (lp1 > *n || e[l] == 0.) {
goto L120;
}
/* apply the transformation. */
/*< do 90 i = lp1, n >*/
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< work(i) = 0.0d0 >*/
work[i__] = 0.;
/*< 90 continue >*/
/* L90: */
}
/*< do 100 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) >*/
i__3 = *n - l;
daxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/*< 100 continue >*/
/* L100: */
}
/*< do 110 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) >*/
i__3 = *n - l;
d__1 = -e[j] / e[lp1];
daxpy_(&i__3, &d__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/*< 110 continue >*/
/* L110: */
}
/*< 120 continue >*/
L120:
/*< if (.not.wantv) go to 140 >*/
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
/*< do 130 i = lp1, p >*/
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< v(i,l) = e(i) >*/
v[i__ + l * v_dim1] = e[i__];
/*< 130 continue >*/
/* L130: */
}
/*< 140 continue >*/
L140:
/*< 150 continue >*/
L150:
/*< 160 continue >*/
/* L160: */
;
}
/*< 170 continue >*/
L170:
/* set up the final bidiagonal matrix or order m. */
/*< m = min0(p,n+1) >*/
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
/*< nctp1 = nct + 1 >*/
nctp1 = nct + 1;
/*< nrtp1 = nrt + 1 >*/
nrtp1 = nrt + 1;
/*< if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) >*/
if (nct < *p) {
s[nctp1] = x[nctp1 + nctp1 * x_dim1];
}
/*< if (n .lt. m) s(m) = 0.0d0 >*/
if (*n < m) {
s[m] = 0.;
}
/*< if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) >*/
if (nrtp1 < m) {
e[nrtp1] = x[nrtp1 + m * x_dim1];
}
/*< e(m) = 0.0d0 >*/
e[m] = 0.;
/* if required, generate u. */
/*< if (.not.wantu) go to 300 >*/
if (! wantu) {
goto L300;
}
/*< if (ncu .lt. nctp1) go to 200 >*/
if (ncu < nctp1) {
goto L200;
}
/*< do 190 j = nctp1, ncu >*/
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
/*< do 180 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,j) = 0.0d0 >*/
u[i__ + j * u_dim1] = 0.;
/*< 180 continue >*/
/* L180: */
}
/*< u(j,j) = 1.0d0 >*/
u[j + j * u_dim1] = 1.;
/*< 190 continue >*/
/* L190: */
}
/*< 200 continue >*/
L200:
/*< if (nct .lt. 1) go to 290 >*/
if (nct < 1) {
goto L290;
}
/*< do 280 ll = 1, nct >*/
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = nct - ll + 1 >*/
l = nct - ll + 1;
/*< if (s(l) .eq. 0.0d0) go to 250 >*/
if (s[l] == 0.) {
goto L250;
}
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (ncu .lt. lp1) go to 220 >*/
if (ncu < lp1) {
goto L220;
}
/*< do 210 j = lp1, ncu >*/
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
/*< t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) >*/
i__3 = *n - l + 1;
t = -ddot_(&i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1) / u[l + l * u_dim1];
/*< call daxpy(n-l+1,t,u(l,l),1,u(l,j),1) >*/
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/*< 210 continue >*/
/* L210: */
}
/*< 220 continue >*/
L220:
/*< call dscal(n-l+1,-1.0d0,u(l,l),1) >*/
i__2 = *n - l + 1;
dscal_(&i__2, &c_b44, &u[l + l * u_dim1], &c__1);
/*< u(l,l) = 1.0d0 + u(l,l) >*/
u[l + l * u_dim1] += 1.;
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< if (lm1 .lt. 1) go to 240 >*/
if (lm1 < 1) {
goto L240;
}
/*< do 230 i = 1, lm1 >*/
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = 0.0d0 >*/
u[i__ + l * u_dim1] = 0.;
/*< 230 continue >*/
/* L230: */
}
/*< 240 continue >*/
L240:
/*< go to 270 >*/
goto L270;
/*< 250 continue >*/
L250:
/*< do 260 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = 0.0d0 >*/
u[i__ + l * u_dim1] = 0.;
/*< 260 continue >*/
/* L260: */
}
/*< u(l,l) = 1.0d0 >*/
u[l + l * u_dim1] = 1.;
/*< 270 continue >*/
L270:
/*< 280 continue >*/
/* L280: */
;
}
/*< 290 continue >*/
L290:
/*< 300 continue >*/
L300:
/* if it is required, generate v. */
/*< if (.not.wantv) go to 350 >*/
if (! wantv) {
goto L350;
}
/*< do 340 ll = 1, p >*/
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = p - ll + 1 >*/
l = *p - ll + 1;
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nrt) go to 320 >*/
if (l > nrt) {
goto L320;
}
/*< if (e(l) .eq. 0.0d0) go to 320 >*/
if (e[l] == 0.) {
goto L320;
}
/*< do 310 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) >*/
i__3 = *p - l;
t = -ddot_(&i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1) / v[lp1 + l * v_dim1];
/*< call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) >*/
i__3 = *p - l;
daxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/*< 310 continue >*/
/* L310: */
}
/*< 320 continue >*/
L320:
/*< do 330 i = 1, p >*/
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< v(i,l) = 0.0d0 >*/
v[i__ + l * v_dim1] = 0.;
/*< 330 continue >*/
/* L330: */
}
/*< v(l,l) = 1.0d0 >*/
v[l + l * v_dim1] = 1.;
/*< 340 continue >*/
/* L340: */
}
/*< 350 continue >*/
L350:
/* main iteration loop for the singular values. */
/*< mm = m >*/
mm = m;
/*< iter = 0 >*/
iter = 0;
/*< 360 continue >*/
L360:
/* quit if all the singular values have been found. */
/* ...exit */
/*< if (m .eq. 0) go to 620 >*/
if (m == 0) {
goto L620;
}
/* if too many iterations have been performed, set */
/* flag and return. */
/*< if (iter .lt. maxit) go to 370 >*/
if (iter < maxit) {
goto L370;
}
/*< info = m >*/
*info = m;
/* ......exit */
/*< go to 620 >*/
goto L620;
/*< 370 continue >*/
L370:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
/*< do 390 ll = 1, m >*/
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = m - ll >*/
l = m - ll;
/* ...exit */
/*< if (l .eq. 0) go to 400 >*/
if (l == 0) {
goto L400;
}
/*< test = dabs(s(l)) + dabs(s(l+1)) >*/
test = (d__1 = s[l], abs(d__1)) + (d__2 = s[l + 1], abs(d__2));
/*< ztest = test + dabs(e(l)) >*/
ztest = test + (d__1 = e[l], abs(d__1));
/*< if (ztest .ne. test) go to 380 >*/
if (ztest != test) {
goto L380;
}
/*< e(l) = 0.0d0 >*/
e[l] = 0.;
/* ......exit */
/*< go to 400 >*/
goto L400;
/*< 380 continue >*/
L380:
/*< 390 continue >*/
/* L390: */
;
}
/*< 400 continue >*/
L400:
/*< if (l .ne. m - 1) go to 410 >*/
if (l != m - 1) {
goto L410;
}
/*< kase = 4 >*/
kase = 4;
/*< go to 480 >*/
goto L480;
/*< 410 continue >*/
L410:
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< mp1 = m + 1 >*/
mp1 = m + 1;
/*< do 430 lls = lp1, mp1 >*/
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
/*< ls = m - lls + lp1 >*/
ls = m - lls + lp1;
/* ...exit */
/*< if (ls .eq. l) go to 440 >*/
if (ls == l) {
goto L440;
}
/*< test = 0.0d0 >*/
test = 0.;
/*< if (ls .ne. m) test = test + dabs(e(ls)) >*/
if (ls != m) {
test += (d__1 = e[ls], abs(d__1));
}
/*< if (ls .ne. l + 1) test = test + dabs(e(ls-1)) >*/
if (ls != l + 1) {
test += (d__1 = e[ls - 1], abs(d__1));
}
/*< ztest = test + dabs(s(ls)) >*/
ztest = test + (d__1 = s[ls], abs(d__1));
/*< if (ztest .ne. test) go to 420 >*/
if (ztest != test) {
goto L420;
}
/*< s(ls) = 0.0d0 >*/
s[ls] = 0.;
/* ......exit */
/*< go to 440 >*/
goto L440;
/*< 420 continue >*/
L420:
/*< 430 continue >*/
/* L430: */
;
}
/*< 440 continue >*/
L440:
/*< if (ls .ne. l) go to 450 >*/
if (ls != l) {
goto L450;
}
/*< kase = 3 >*/
kase = 3;
/*< go to 470 >*/
goto L470;
/*< 450 continue >*/
L450:
/*< if (ls .ne. m) go to 460 >*/
if (ls != m) {
goto L460;
}
/*< kase = 1 >*/
kase = 1;
/*< go to 470 >*/
goto L470;
/*< 460 continue >*/
L460:
/*< kase = 2 >*/
kase = 2;
/*< l = ls >*/
l = ls;
/*< 470 continue >*/
L470:
/*< 480 continue >*/
L480:
/*< l = l + 1 >*/
++l;
/* perform the task indicated by kase. */
/*< go to (490,520,540,570), kase >*/
switch (kase) {
case 1: goto L490;
case 2: goto L520;
case 3: goto L540;
case 4: goto L570;
}
/* deflate negligible s(m). */
/*< 490 continue >*/
L490:
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< f = e(m-1) >*/
f = e[m - 1];
/*< e(m-1) = 0.0d0 >*/
e[m - 1] = 0.;
/*< do 510 kk = l, mm1 >*/
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
/*< k = mm1 - kk + l >*/
k = mm1 - kk + l;
/*< t1 = s(k) >*/
t1 = s[k];
/*< call drotg(t1,f,cs,sn) >*/
drotg_(&t1, &f, &cs, &sn);
/*< s(k) = t1 >*/
s[k] = t1;
/*< if (k .eq. l) go to 500 >*/
if (k == l) {
goto L500;
}
/*< f = -sn*e(k-1) >*/
f = -sn * e[k - 1];
/*< e(k-1) = cs*e(k-1) >*/
e[k - 1] = cs * e[k - 1];
/*< 500 continue >*/
L500:
/*< if (wantv) call drot(p,v(1,k),1,v(1,m),1,cs,sn) >*/
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/*< 510 continue >*/
/* L510: */
}
/*< go to 610 >*/
goto L610;
/* split at negligible s(l). */
/*< 520 continue >*/
L520:
/*< f = e(l-1) >*/
f = e[l - 1];
/*< e(l-1) = 0.0d0 >*/
e[l - 1] = 0.;
/*< do 530 k = l, m >*/
i__1 = m;
for (k = l; k <= i__1; ++k) {
/*< t1 = s(k) >*/
t1 = s[k];
/*< call drotg(t1,f,cs,sn) >*/
drotg_(&t1, &f, &cs, &sn);
/*< s(k) = t1 >*/
s[k] = t1;
/*< f = -sn*e(k) >*/
f = -sn * e[k];
/*< e(k) = cs*e(k) >*/
e[k] = cs * e[k];
/*< if (wantu) call drot(n,u(1,k),1,u(1,l-1),1,cs,sn) >*/
if (wantu) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 530 continue >*/
/* L530: */
}
/*< go to 610 >*/
goto L610;
/* perform one qr step. */
/*< 540 continue >*/
L540:
/* calculate the shift. */
/*< >*/
/* Computing MAX */
d__6 = (d__1 = s[m], abs(d__1)), d__7 = (d__2 = s[m - 1], abs(d__2)),
d__6 = max(d__6,d__7), d__7 = (d__3 = e[m - 1], abs(d__3)), d__6 =
max(d__6,d__7), d__7 = (d__4 = s[l], abs(d__4)), d__6 = max(d__6,
d__7), d__7 = (d__5 = e[l], abs(d__5));
scale = max(d__6,d__7);
/*< sm = s(m)/scale >*/
sm = s[m] / scale;
/*< smm1 = s(m-1)/scale >*/
smm1 = s[m - 1] / scale;
/*< emm1 = e(m-1)/scale >*/
emm1 = e[m - 1] / scale;
/*< sl = s(l)/scale >*/
sl = s[l] / scale;
/*< el = e(l)/scale >*/
el = e[l] / scale;
/*< b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0d0 >*/
/* Computing 2nd power */
d__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + d__1 * d__1) / 2.;
/*< c = (sm*emm1)**2 >*/
/* Computing 2nd power */
d__1 = sm * emm1;
c__ = d__1 * d__1;
/*< shift = 0.0d0 >*/
shift = 0.;
/*< if (b .eq. 0.0d0 .and. c .eq. 0.0d0) go to 550 >*/
if (b == 0. && c__ == 0.) {
goto L550;
}
/*< shift = dsqrt(b**2+c) >*/
/* Computing 2nd power */
d__1 = b;
shift = sqrt(d__1 * d__1 + c__);
/*< if (b .lt. 0.0d0) shift = -shift >*/
if (b < 0.) {
shift = -shift;
}
/*< shift = c/(b + shift) >*/
shift = c__ / (b + shift);
/*< 550 continue >*/
L550:
/*< f = (sl + sm)*(sl - sm) + shift >*/
f = (sl + sm) * (sl - sm) + shift;
/*< g = sl*el >*/
g = sl * el;
/* chase zeros. */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 560 k = l, mm1 >*/
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
/*< call drotg(f,g,cs,sn) >*/
drotg_(&f, &g, &cs, &sn);
/*< if (k .ne. l) e(k-1) = f >*/
if (k != l) {
e[k - 1] = f;
}
/*< f = cs*s(k) + sn*e(k) >*/
f = cs * s[k] + sn * e[k];
/*< e(k) = cs*e(k) - sn*s(k) >*/
e[k] = cs * e[k] - sn * s[k];
/*< g = sn*s(k+1) >*/
g = sn * s[k + 1];
/*< s(k+1) = cs*s(k+1) >*/
s[k + 1] = cs * s[k + 1];
/*< if (wantv) call drot(p,v(1,k),1,v(1,k+1),1,cs,sn) >*/
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
/*< call drotg(f,g,cs,sn) >*/
drotg_(&f, &g, &cs, &sn);
/*< s(k) = f >*/
s[k] = f;
/*< f = cs*e(k) + sn*s(k+1) >*/
f = cs * e[k] + sn * s[k + 1];
/*< s(k+1) = -sn*e(k) + cs*s(k+1) >*/
s[k + 1] = -sn * e[k] + cs * s[k + 1];
/*< g = sn*e(k+1) >*/
g = sn * e[k + 1];
/*< e(k+1) = cs*e(k+1) >*/
e[k + 1] = cs * e[k + 1];
/*< >*/
if (wantu && k < *n) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 560 continue >*/
/* L560: */
}
/*< e(m-1) = f >*/
e[m - 1] = f;
/*< iter = iter + 1 >*/
++iter;
/*< go to 610 >*/
goto L610;
/* convergence. */
/*< 570 continue >*/
L570:
/* make the singular value positive. */
/*< if (s(l) .ge. 0.0d0) go to 580 >*/
if (s[l] >= 0.) {
goto L580;
}
/*< s(l) = -s(l) >*/
s[l] = -s[l];
/*< if (wantv) call dscal(p,-1.0d0,v(1,l),1) >*/
if (wantv) {
dscal_(p, &c_b44, &v[l * v_dim1 + 1], &c__1);
}
/*< 580 continue >*/
L580:
/* order the singular value. */
/*< 590 if (l .eq. mm) go to 600 >*/
L590:
if (l == mm) {
goto L600;
}
/* ...exit */
/*< if (s(l) .ge. s(l+1)) go to 600 >*/
if (s[l] >= s[l + 1]) {
goto L600;
}
/*< t = s(l) >*/
t = s[l];
/*< s(l) = s(l+1) >*/
s[l] = s[l + 1];
/*< s(l+1) = t >*/
s[l + 1] = t;
/*< >*/
if (wantv && l < *p) {
dswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
/*< >*/
if (wantu && l < *n) {
dswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
/*< l = l + 1 >*/
++l;
/*< go to 590 >*/
goto L590;
/*< 600 continue >*/
L600:
/*< iter = 0 >*/
iter = 0;
/*< m = m - 1 >*/
--m;
/*< 610 continue >*/
L610:
/*< go to 360 >*/
goto L360;
/*< 620 continue >*/
L620:
/*< return >*/
return 0;
/*< end >*/
} /* dsvdc_ */
/* Subroutine */
int dbols_(doublereal* w, integer* mdw, integer* mrows,
integer* ncols, doublereal* bl, doublereal* bu, integer* ind, integer
*iopt, doublereal* x, doublereal* rnorm, integer* mode, doublereal *
rw, integer* iw)
{
/* Initialized data */
static integer igo = 0;
/* System generated locals */
integer w_dim1, w_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer i__, j;
static doublereal sc;
static integer ip, jp, lp;
static doublereal ss;
static integer llb;
static doublereal one;
static integer lds, llx, ibig, idum, lmdw, lndw, nerr;
static real rdum;
static integer lenx, lliw, mnew;
extern /* Subroutine */ int drot_(integer*, doublereal*, integer*,
doublereal*, integer*, doublereal*, doublereal*);
static integer lopt;
static doublereal zero;
static integer llrw;
extern doublereal dnrm2_(integer*, doublereal*, integer*);
static real rdum2;
static integer nchar, level;
extern /* Subroutine */ int dcopy_(integer*, doublereal*, integer*,
doublereal*, integer*), drotg_(doublereal*, doublereal*,
doublereal*, doublereal*);
static integer liopt, locacc;
static logical checkl;
static integer iscale;
extern integer idamax_(integer*, doublereal*, integer*);
static integer locdim;
extern /* Subroutine */ int dbolsm_(doublereal*, integer*, integer*,
integer*, doublereal*, doublereal*, integer*, integer*,
doublereal*, doublereal*, integer*, doublereal*, doublereal*,
doublereal*, integer*, integer*);
static integer inrows;
extern /* Subroutine */ int xerrwv_(char*, integer*, integer*, integer
*, integer*, integer*, integer*, integer*, real*, real*,
ftnlen);
/* ***BEGIN PROLOGUE DBOLS */
/* ***DATE WRITTEN 821220 (YYMMDD) */
/* ***REVISION DATE 861211 (YYMMDD) */
/* ***CATEGORY NO. K1A2A,G2E,G2H1,G2H2 */
/* ***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(SBOLS-S DBOLS-D), */
/* BOUNDS,CONSTRAINTS,INEQUALITY,LEAST SQUARES,LINEAR */
/* ***AUTHOR HANSON, R. J., SNLA */
/* ***PURPOSE Solve the problem */
/* E*X = F (in the least squares sense) */
/* with bounds on selected X values. */
/* ***DESCRIPTION */
/* **** Double Precision Version of SBOLS **** */
/* **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** */
/* The user must have dimension statements of the form: */
/* DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), */
/* * X(NCOLS+NX), RW(5*NCOLS) */
/* INTEGER IND(NCOLS), IOPT(1+NI), IW(2*NCOLS) */
/* (here NX=number of extra locations required for option 4; NX=0 */
/* for no options; NX=NCOLS if this option is in use. Here NI=number */
/* of extra locations required for options 1-6; NI=0 for no */
/* options.) */
/* INPUT */
/* ----- */
/* -------------------- */
/* W(MDW,*),MROWS,NCOLS */
/* -------------------- */
/* The array W(*,*) contains the matrix [E:F] on entry. The matrix */
/* [E:F] has MROWS rows and NCOLS+1 columns. This data is placed in */
/* the array W(*,*) with E occupying the first NCOLS columns and the */
/* right side vector F in column NCOLS+1. The row dimension, MDW, of */
/* the array W(*,*) must satisfy the inequality MDW .ge. MROWS. */
/* Other values of MDW are errrors. The values of MROWS and NCOLS */
/* must be positive. Other values are errors. There is an exception */
/* to this when using option 1 for accumulation of blocks of */
/* equations. In that case MROWS is an OUTPUT variable ONLY, and the */
/* matrix data for [E:F] is placed in W(*,*), one block of rows at a */
/* time. MROWS contains the number of rows in the matrix after */
/* triangularizing several blocks of equations. This is an OUTPUT */
/* parameter ONLY when option 1 is used. See IOPT(*) CONTENTS */
/* for details about option 1. */
/* ------------------ */
/* BL(*),BU(*),IND(*) */
/* ------------------ */
/* These arrays contain the information about the bounds that the */
/* solution values are to satisfy. The value of IND(J) tells the */
/* type of bound and BL(J) and BU(J) give the explicit values for */
/* the respective upper and lower bounds. */
/* 1. For IND(J)=1, require X(J) .ge. BL(J). */
/* (the value of BU(J) is not used.) */
/* 2. For IND(J)=2, require X(J) .le. BU(J). */
/* (the value of BL(J) is not used.) */
/* 3. For IND(J)=3, require X(J) .ge. BL(J) and */
/* X(J) .le. BU(J). */
/* 4. For IND(J)=4, no bounds on X(J) are required. */
/* (the values of BL(J) and BU(J) are not used.) */
/* Values other than 1,2,3 or 4 for IND(J) are errors. In the case */
/* IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) */
/* is an error. */
/* ------- */
/* IOPT(*) */
/* ------- */
/* This is the array where the user can specify nonstandard options */
/* for DBOLSM( ). Most of the time this feature can be ignored by */
/* setting the input value IOPT(1)=99. Occasionally users may have */
/* needs that require use of the following subprogram options. For */
/* details about how to use the options see below: IOPT(*) CONTENTS. */
/* Option Number Brief Statement of Purpose */
/* ------ ------ ----- --------- -- ------- */
/* 1 Return to user for accumulation of blocks */
/* of least squares equations. */
/* 2 Check lengths of all arrays used in the */
/* subprogram. */
/* 3 Standard scaling of the data matrix, E. */
/* 4 User provides column scaling for matrix E. */
/* 5 Provide option array to the low-level */
/* subprogram DBOLSM( ). */
/* 6 Move the IOPT(*) processing pointer. */
/* 99 No more options to change. */
/* ---- */
/* X(*) */
/* ---- */
/* This array is used to pass data associated with option 4. Ignore */
/* this parameter if this option is not used. Otherwise see below: */
/* IOPT(*) CONTENTS. */
/* OUTPUT */
/* ------ */
/* ---------- */
/* X(*),RNORM */
/* ---------- */
/* The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for */
/* the constrained least squares problem. The value RNORM is the */
/* minimum residual vector length. */
/* ---- */
/* MODE */
/* ---- */
/* The sign of MODE determines whether the subprogram has completed */
/* normally, or encountered an error condition or abnormal status. A */
/* value of MODE .ge. 0 signifies that the subprogram has completed */
/* normally. The value of MODE (.GE. 0) is the number of variables */
/* in an active status: not at a bound nor at the value ZERO, for */
/* the case of free variables. A negative value of MODE will be one */
/* of the cases -37,-36,...,-22, or -17,...,-2. Values .lt. -1 */
/* correspond to an abnormal completion of the subprogram. To */
/* understand the abnormal completion codes see below: ERROR */
/* MESSAGES for DBOLS( ). AN approximate solution will be returned */
/* to the user only when max. iterations is reached, MODE=-22. */
/* Values for MODE=-37,...,-22 come from the low-level subprogram */
/* DBOLSM(). See the section ERROR MESSAGES for DBOLSM() in the */
/* documentation for DBOLSM(). */
/* ----------- */
/* RW(*),IW(*) */
/* ----------- */
/* These are working arrays with 5*NCOLS and 2*NCOLS entries. */
/* (normally the user can ignore the contents of these arrays, */
/* but they must be dimensioned properly.) */
/* IOPT(*) CONTENTS */
/* ------- -------- */
/* The option array allows a user to modify internal variables in */
/* the subprogram without recompiling the source code. A central */
/* goal of the initial software design was to do a good job for most */
/* people. Thus the use of options will be restricted to a select */
/* group of users. The processing of the option array proceeds as */
/* follows: a pointer, here called LP, is initially set to the value */
/* 1. This value is updated as each option is processed. At the */
/* pointer position the option number is extracted and used for */
/* locating other information that allows for options to be changed. */
/* The portion of the array IOPT(*) that is used for each option is */
/* fixed; the user and the subprogram both know how many locations */
/* are needed for each option. A great deal of error checking is */
/* done by the subprogram on the contents of the option array. */
/* Nevertheless it is still possible to give the subprogram optional */
/* input that is meaningless. For example option 4 uses the */
/* locations X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing */
/* scaling data. The user must manage the allocation of these */
/* locations. */
/* 1 */
/* - */
/* This option allows the user to solve problems with a large number */
/* of rows compared to the number of variables. The idea is that the */
/* subprogram returns to the user (perhaps many times) and receives */
/* new least squares equations from the calling program unit. */
/* Eventually the user signals "that's all" and then computes the */
/* solution with one final call to subprogram DBOLS( ). The value of */
/* MROWS is an OUTPUT variable when this option is used. Its value */
/* is always in the range 0 .le. MROWS .le. NCOLS+1. It is equal to */
/* the number of rows after the triangularization of the entire set */
/* of equations. If LP is the processing pointer for IOPT(*), the */
/* usage for the sequential processing of blocks of equations is */
/* IOPT(LP)=1 */
/* Move block of equations to W(*,*) starting at */
/* the first row of W(*,*). */
/* IOPT(LP+3)=# of rows in the block; user defined */
/* The user now calls DBOLS( ) in a loop. The value of IOPT(LP+1) */
/* directs the user's action. The value of IOPT(LP+2) points to */
/* where the subsequent rows are to be placed in W(*,*). */
/* .<LOOP */
/* . CALL DBOLS() */
/* . IF(IOPT(LP+1) .EQ. 1) THEN */
/* . IOPT(LP+3)=# OF ROWS IN THE NEW BLOCK; USER DEFINED */
/* . PLACE NEW BLOCK OF IOPT(LP+3) ROWS IN */
/* . W(*,*) STARTING AT ROW IOPT(LP+2). */
/* . */
/* . IF( THIS IS THE LAST BLOCK OF EQUATIONS ) THEN */
/* . IOPT(LP+1)=2 */
/* .<------CYCLE LOOP */
/* . ELSE IF (IOPT(LP+1) .EQ. 2) THEN */
/* <-------EXIT LOOP SOLUTION COMPUTED IF MODE .GE. 0 */
/* . ELSE */
/* . ERROR CONDITION; SHOULD NOT HAPPEN. */
/* .<END LOOP */
/* Use of this option adds 4 to the required length of IOPT(*). */
/* 2 */
/* - */
/* This option is useful for checking the lengths of all arrays used */
/* by DBOLS() against their actual requirements for this problem. */
/* The idea is simple: the user's program unit passes the declared */
/* dimension information of the arrays. These values are compared */
/* against the problem-dependent needs within the subprogram. If any */
/* of the dimensions are too small an error message is printed and a */
/* negative value of MODE is returned, -11 to -17. The printed error */
/* message tells how long the dimension should be. If LP is the */
/* processing pointer for IOPT(*), */
/* IOPT(LP)=2 */
/* IOPT(LP+1)=Row dimension of W(*,*) */
/* IOPT(LP+2)=Col. dimension of W(*,*) */
/* IOPT(LP+3)=Dimensions of BL(*),BU(*),IND(*) */
/* IOPT(LP+4)=Dimension of X(*) */
/* IOPT(LP+5)=Dimension of RW(*) */
/* IOPT(LP+6)=Dimension of IW(*) */
/* IOPT(LP+7)=Dimension of IOPT(*) */
/* . */
/* CALL DBOLS() */
/* Use of this option adds 8 to the required length of IOPT(*). */
/* 3 */
/* - */
/* This option changes the type of scaling for the data matrix E. */
/* Nominally each nonzero column of E is scaled so that the */
/* magnitude of its largest entry is equal to the value ONE. If LP */
/* is the processing pointer for IOPT(*), */
/* IOPT(LP)=3 */
/* IOPT(LP+1)=1,2 or 3 */
/* 1= Nominal scaling as noted; */
/* 2= Each nonzero column scaled to have length ONE; */
/* 3= Identity scaling; scaling effectively suppressed. */
/* . */
/* CALL DBOLS() */
/* Use of this option adds 2 to the required length of IOPT(*). */
/* 4 */
/* - */
/* This option allows the user to provide arbitrary (positive) */
/* column scaling for the matrix E. If LP is the processing pointer */
/* for IOPT(*), */
/* IOPT(LP)=4 */
/* IOPT(LP+1)=IOFF */
/* X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) */
/* = Positive scale factors for cols. of E. */
/* . */
/* CALL DBOLS() */
/* Use of this option adds 2 to the required length of IOPT(*) and */
/* NCOLS to the required length of X(*). */
/* 5 */
/* - */
/* This option allows the user to provide an option array to the */
/* low-level subprogram DBOLSM(). If LP is the processing pointer */
/* for IOPT(*), */
/* IOPT(LP)=5 */
/* IOPT(LP+1)= Position in IOPT(*) where option array */
/* data for DBOLSM() begins. */
/* . */
/* CALL DBOLS() */
/* Use of this option adds 2 to the required length of IOPT(*). */
/* 6 */
/* - */
/* Move the processing pointer (either forward or backward) to the */
/* location IOPT(LP+1). The processing point is moved to entry */
/* LP+2 of IOPT(*) if the option is left with -6 in IOPT(LP). For */
/* example to skip over locations 3,...,NCOLS+2 of IOPT(*), */
/* IOPT(1)=6 */
/* IOPT(2)=NCOLS+3 */
/* (IOPT(I), I=3,...,NCOLS+2 are not defined here.) */
/* IOPT(NCOLS+3)=99 */
/* CALL DBOLS() */
/* CAUTION: Misuse of this option can yield some very hard */
/* -to-find bugs. Use it with care. */
/* 99 */
/* -- */
/* There are no more options to change. */
/* Only option numbers -99, -6,-5,...,-1, 1,2,...,6, and 99 are */
/* permitted. Other values are errors. Options -99,-1,...,-6 mean */
/* that the repective options 99,1,...,6 are left at their default */
/* values. An example is the option to modify the (rank) tolerance: */
/* IOPT(1)=-3 Option is recognized but not changed */
/* IOPT(2)=2 Scale nonzero cols. to have length ONE */
/* IOPT(3)=99 */
/* ERROR MESSAGES for DBOLS() */
/* ----- -------- --- ------- */
/* WARNING IN... */
/* DBOLS(). MDW=(I1) MUST BE POSITIVE. */
/* IN ABOVE MESSAGE, I1= 0 */
/* ERROR NUMBER = 2 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITIVE. */
/* IN ABOVE MESSAGE, I1= 0 */
/* ERROR NUMBER = 3 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4. */
/* IN ABOVE MESSAGE, I1= 1 */
/* IN ABOVE MESSAGE, I2= 0 */
/* ERROR NUMBER = 4 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. BU(J)=(R2). */
/* IN ABOVE MESSAGE, I1= 1 */
/* IN ABOVE MESSAGE, R1= 0. */
/* IN ABOVE MESSAGE, R2= ABOVE MESSAGE, I1= 0 */
/* ERROR NUMBER = 6 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). ISCALE OPTION=(I1) MUST BE 1-3. */
/* IN ABOVE MESSAGE, I1= 0 */
/* ERROR NUMBER = 7 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED COLUMN SCALING */
/* MUST BE POSITIVE. */
/* IN ABOVE MESSAGE, I1= 0 */
/* ERROR NUMBER = 8 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE. */
/* COMPONENT (I1) NOW = (R1). */
/* IN ABOVE MESSAGE, I1= ND. .LE. MDW=(I2). */
/* IN ABOVE MESSAGE, I1= 1 */
/* IN ABOVE MESSAGE, I2= 0 */
/* ERROR NUMBER = 10 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS().THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE.THE NUMBER OF ROWS= */
/* (I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 1 */
/* ERROR NUMBER = 11 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE .GE. NCOLS+1=(I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 2 */
/* ERROR NUMBER = 12 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS().THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) MUST BE */
/* .GE. NCOLS=(I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 1 */
/* ERROR NUMBER = 13 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). THE DIMENSION OF X()=(I1) MUST BE .GE. THE REQD. LENGTH=(I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 2 */
/* ERROR NUMBER = 14 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS(). THE DIMENSION OF RW()=(I1) MUST BE .GE. 5*NCOLS=(I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 3 */
/* ERROR NUMBER = 15 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*NCOLS=(I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 2 */
/* ERROR NUMBER = 16 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* WARNING IN... */
/* DBOLS() THE DIMENSION OF IOPT()=(I1) MUST BE .GE. THE REQD. LEN.=(I2). */
/* IN ABOVE MESSAGE, I1= 0 */
/* IN ABOVE MESSAGE, I2= 1 */
/* ERROR NUMBER = 17 */
/* (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) */
/* ***REFERENCES HANSON, R. J. LINEAR LEAST SQUARES WITH BOUNDS AND */
/* LINEAR CONSTRAINTS, SNLA REPT. SAND82-1517, AUG.,1982 */
/* ***ROUTINES CALLED DBOLSM,DCOPY,DNRM2,DROT,DROTG,IDAMAX,XERRWV */
/* ***END PROLOGUE DBOLS */
/* SOLVE LINEAR LEAST SQUARES SYSTEM WITH BOUNDS ON */
/* SELECTED VARIABLES. */
/* REVISED 850329-1400 */
/* REVISED YYMMDD-HHMM */
/* TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN */
/* EDITING AT THE CARD 'C++'. */
/* CHANGE THIS SUBPROGRAM NAME TO DBOLS AND THE STRINGS */
/* /SCOPY/ TO /DCOPY/, /SBOL/ TO /DBOL/, */
/* /SNRM2/ TO /DNRM2/, /ISAMAX/ TO /IDAMAX/, */
/* /SROTG/ TO /DROTG/, /SROT/ TO /DROT/, /E0/ TO /D0/, */
/* /REAL / TO /DOUBLE PRECISION/. */
/* ++ */
/* THIS VARIABLE SHOULD REMAIN TYPE REAL. */
/* Parameter adjustments */
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
--bl;
--bu;
--ind;
--iopt;
--x;
--rw;
--iw;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT DBOLS */
level = 1;
nerr = 0;
*mode = 0;
if (igo == 0) {
/* DO(CHECK VALIDITY OF INPUT DATA) */
/* PROCEDURE(CHECK VALIDITY OF INPUT DATA) */
/* SEE THAT MDW IS .GT.0. GROSS CHECK ONLY. */
if (*mdw <= 0) {
nerr = 2;
nchar = 35;
xerrwv_("DBOLS(). MDW=(I1) MUST BE POSITIVE.", &nchar, &nerr, &
level, &c__1, mdw, &idum, &c__0, &rdum, &rdum, (ftnlen)35)
;
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
/* SEE THAT NUMBER OF UNKNOWNS IS POSITIVE. */
if (*ncols <= 0) {
nerr = 3;
nchar = 58;
xerrwv_("DBOLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITI"
"VE.", &nchar, &nerr, &level, &c__1, ncols, &idum, &c__0, &
rdum, &rdum, (ftnlen)58);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
/* SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED. */
i__1 = *ncols;
for (j = 1; j <= i__1; ++j) {
if (ind[j] < 1 || ind[j] > 4) {
nerr = 4;
nchar = 45;
xerrwv_("DBOLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4.", &
nchar, &nerr, &level, &c__2, &j, &ind[j], &c__0, &
rdum, &rdum, (ftnlen)45);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
/* L10: */
}
/* SEE THAT BOUNDS ARE CONSISTENT. */
i__1 = *ncols;
for (j = 1; j <= i__1; ++j) {
if (ind[j] == 3) {
if (bl[j] > bu[j]) {
nerr = 5;
nchar = 57;
rdum2 = (real) bl[j];
rdum = (real) bu[j];
xerrwv_("DBOLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. B"
"U(J)=(R2).", &nchar, &nerr, &level, &c__1, &j, &
idum, &c__2, &rdum2, &rdum, (ftnlen)57);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
}
/* L20: */
}
/* END PROCEDURE */
/* DO(PROCESS OPTION ARRAY) */
/* PROCEDURE(PROCESS OPTION ARRAY) */
zero = 0.;
one = 1.;
checkl = FALSE_;
lenx = *ncols;
iscale = 1;
igo = 2;
lopt = 0;
lp = 0;
lds = 0;
L30:
lp += lds;
ip = iopt[lp + 1];
jp = abs(ip);
/* TEST FOR NO MORE OPTIONS. */
if (ip == 99) {
if (lopt == 0) {
lopt = lp + 1;
}
goto L50;
} else if (jp == 99) {
lds = 1;
goto L30;
} else if (jp == 1) {
if (ip > 0) {
/* SET UP DIRECTION FLAG, ROW STACKING POINTER */
/* LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS. */
locacc = lp + 2;
/* IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION. */
/* CONTENTS.. IOPT(LOCACC )=USER DIRECTION FLAG, 1 OR 2. */
/* IOPT(LOCACC+1)=ROW STACKING POINTER. */
/* IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS. */
/* USER ACTION WITH THIS OPTION.. */
/* (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*). */
/* MUST ALSO START PROCESS WITH IOPT(LOCACC)=1.) */
/* (MOVE BLOCK OF EQUATIONS INTO W(*,*) STARTING AT FIRST */
/* ROW OF W(*,*). SET IOPT(LOCACC+2)=NO. OF ROWS IN BLOCK.) */
/* LOOP */
/* CALL DBOLS() */
/* IF(IOPT(LOCACC) .EQ. 1) THEN */
/* STACK EQUAS., STARTING AT ROW IOPT(LOCACC+1), */
/* INTO W(*,*). */
/* SET IOPT(LOCACC+2)=NO. OF EQUAS. */
/* IF LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2. */
/* ELSE IF IOPT(LOCACC) .EQ. 2) THEN */
/* (PROCESS IS OVER. EXIT LOOP.) */
/* ELSE */
/* (ERROR CONDITION. SHOULD NOT HAPPEN.) */
/* END IF */
/* END LOOP */
/* SET IOPT(LOCACC-1)=-OPTION NUMBER FOR SEQ. ACCUMULATION. */
/* CALL DBOLS( ) */
iopt[locacc + 1] = 1;
igo = 1;
}
lds = 4;
goto L30;
} else if (jp == 2) {
if (ip > 0) {
/* GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS. */
locdim = lp + 2;
/* LMDW.GE.MROWS */
/* LNDW.GE.NCOLS+1 */
/* LLB .GE.NCOLS */
/* LLX .GE.NCOLS+EXTRA REQD. IN OPTIONS. */
/* LLRW.GE.5*NCOLS */
/* LLIW.GE.2*NCOLS */
/* LIOP.GE. AMOUNT REQD. FOR IOPTION ARRAY. */
lmdw = iopt[locdim];
lndw = iopt[locdim + 1];
llb = iopt[locdim + 2];
llx = iopt[locdim + 3];
llrw = iopt[locdim + 4];
lliw = iopt[locdim + 5];
liopt = iopt[locdim + 6];
checkl = TRUE_;
}
lds = 8;
goto L30;
/* OPTION TO MODIFY THE COLUMN SCALING. */
} else if (jp == 3) {
if (ip > 0) {
iscale = iopt[lp + 2];
/* SEE THAT ISCALE IS 1 THRU 3. */
if (iscale < 1 || iscale > 3) {
nerr = 7;
nchar = 40;
xerrwv_("DBOLS(). ISCALE OPTION=(I1) MUST BE 1-3.", &
nchar, &nerr, &level, &c__1, &iscale, &idum, &
c__0, &rdum, &rdum, (ftnlen)40);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
}
lds = 2;
/* CYCLE FOREVER */
goto L30;
/* IN THIS OPTION THE USER HAS PROVIDED SCALING. THE */
/* SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)). */
} else if (jp == 4) {
if (ip > 0) {
iscale = 4;
if (iopt[lp + 2] <= 0) {
nerr = 8;
nchar = 85;
xerrwv_("DBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PRO"
"VIDED COLUMN SCALING MUST BE POSITIVE.", &nchar, &
nerr, &level, &c__1, &iopt[lp + 2], &idum, &c__0,
&rdum, &rdum, (ftnlen)85);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
dcopy_(ncols, &x[*ncols + iopt[lp + 2]], &c__1, &rw[1], &c__1)
;
lenx += *ncols;
i__1 = *ncols;
for (j = 1; j <= i__1; ++j) {
if (rw[j] <= zero) {
nerr = 9;
nchar = 85;
rdum2 = (real) rw[j];
xerrwv_("DBOLS(). EACH PROVIDED COL. SCALE FACTOR MU"
"ST BE POSITIVE. COMPONENT (I1) NOW = (R1).", &
nchar, &nerr, &level, &c__1, &j, &idum, &c__1,
&rdum2, &rdum, (ftnlen)85);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
/* L40: */
}
}
lds = 2;
/* CYCLE FOREVER */
goto L30;
/* IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLSM(). */
} else if (jp == 5) {
if (ip > 0) {
lopt = iopt[lp + 2];
}
lds = 2;
/* CYCLE FOREVER */
goto L30;
/* THIS OPTION USES THE NEXT LOC OF IOPT(*) AS AN */
/* INCREMENT TO SKIP. */
} else if (jp == 6) {
if (ip > 0) {
lp = iopt[lp + 2] - 1;
lds = 0;
} else {
lds = 2;
}
/* CYCLE FOREVER */
goto L30;
/* NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION. */
} else {
nerr = 6;
nchar = 47;
rdum2 = (real) idum;
xerrwv_("DBOLS(). THE OPTION NUMBER=(I1) IS NOT DEFINED.", &nchar,
&nerr, &level, &c__1, &jp, &idum, &c__0, &rdum2, &rdum2,
(ftnlen)47);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
L50:
/* END PROCEDURE */
if (checkl) {
/* DO(CHECK LENGTHS OF ARRAYS) */
/* PROCEDURE(CHECK LENGTHS OF ARRAYS) */
/* THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE */
/* ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE. */
if (lmdw < *mrows) {
nerr = 11;
nchar = 76;
xerrwv_("DBOLS(). THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE"
".THE NUMBER OF ROWS=(I2).", &nchar, &nerr, &level, &
c__2, &lmdw, mrows, &c__0, &rdum, &rdum, (ftnlen)76);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
if (lndw < *ncols + 1) {
nerr = 12;
nchar = 69;
i__1 = *ncols + 1;
xerrwv_("DBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE "
".GE. NCOLS+1=(I2).", &nchar, &nerr, &level, &c__2, &
lndw, &i__1, &c__0, &rdum, &rdum, (ftnlen)69);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
if (llb < *ncols) {
nerr = 13;
nchar = 88;
xerrwv_("DBOLS(). THE DIMENSIONS OF THE ARRAYS BL(),BU(), AN"
"D IND()=(I1) MUST BE .GE. NCOLS=(I2).", &nchar, &nerr,
&level, &c__2, &llb, ncols, &c__0, &rdum, &rdum, (
ftnlen)88);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
if (llx < lenx) {
nerr = 14;
nchar = 70;
xerrwv_("DBOLS(). THE DIMENSION OF X()=(I1) MUST BE .GE. THE"
" REQD. LENGTH=(I2).", &nchar, &nerr, &level, &c__2, &
llx, &lenx, &c__0, &rdum, &rdum, (ftnlen)70);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
if (llrw < *ncols * 5) {
nerr = 15;
nchar = 62;
i__1 = *ncols * 5;
xerrwv_("DBOLS(). THE DIMENSION OF RW()=(I1) MUST BE .GE. 5*"
"NCOLS=(I2).", &nchar, &nerr, &level, &c__2, &llrw, &
i__1, &c__0, &rdum, &rdum, (ftnlen)62);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
if (lliw < *ncols << 1) {
nerr = 16;
nchar = 61;
i__1 = *ncols << 1;
xerrwv_("DBOLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*N"
"COLS=(I2).", &nchar, &nerr, &level, &c__2, &lliw, &
i__1, &c__0, &rdum, &rdum, (ftnlen)61);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
if (liopt < lp + 1) {
nerr = 17;
nchar = 71;
i__1 = lp + 1;
xerrwv_("DBOLS(). THE DIMENSION OF IOPT()=(I1) MUST BE .GE. "
"THE REQD. LEN.=(I2).", &nchar, &nerr, &level, &c__2, &
liopt, &i__1, &c__0, &rdum, &rdum, (ftnlen)71);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
/* END PROCEDURE */
}
}
switch (igo) {
case 1:
goto L60;
case 2:
goto L90;
}
goto L180;
/* GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES */
/* EQUATIONS AND DIRECTIONS TO QUIT PROCESSING. */
/* CASE 1 */
L60:
/* DO(ACCUMULATE LEAST SQUARES EQUATIONS) */
/* PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS) */
*mrows = iopt[locacc + 1] - 1;
inrows = iopt[locacc + 2];
mnew = *mrows + inrows;
if (mnew < 0 || mnew > *mdw) {
nerr = 10;
nchar = 61;
xerrwv_("DBOLS(). NO. OF ROWS=(I1) MUST BE .GE. 0 .AND. .LE. MDW=(I2"
").", &nchar, &nerr, &level, &c__2, &mnew, mdw, &c__0, &rdum, &
rdum, (ftnlen)61);
/* DO(RETURN TO USER PROGRAM UNIT) */
goto L190;
}
/* Computing MIN */
i__2 = *ncols + 1;
i__1 = min(i__2,mnew);
for (j = 1; j <= i__1; ++j) {
i__2 = max(*mrows,j) + 1;
for (i__ = mnew; i__ >= i__2; --i__) {
i__3 = i__ - j;
ibig = idamax_(&i__3, &w[j + j * w_dim1], &c__1) + j - 1;
/* PIVOT FOR INCREASED STABILITY. */
drotg_(&w[ibig + j * w_dim1], &w[i__ + j * w_dim1], &sc, &ss);
i__3 = *ncols + 1 - j;
drot_(&i__3, &w[ibig + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) *
w_dim1], mdw, &sc, &ss);
w[i__ + j * w_dim1] = zero;
/* L70: */
}
/* L80: */
}
/* Computing MIN */
i__1 = *ncols + 1;
*mrows = min(i__1,mnew);
iopt[locacc + 1] = *mrows + 1;
igo = iopt[locacc];
/* END PROCEDURE */
if (igo == 2) {
igo = 0;
}
goto L180;
/* CASE 2 */
L90:
/* DO(INITIALIZE VARIABLES AND DATA VALUES) */
/* PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES) */
i__1 = *ncols;
for (j = 1; j <= i__1; ++j) {
switch (iscale) {
case 1:
goto L100;
case 2:
goto L110;
case 3:
goto L120;
case 4:
goto L130;
}
goto L140;
L100:
/* CASE 1 */
/* THIS IS THE NOMINAL SCALING. EACH NONZERO */
/* COL. HAS MAX. NORM EQUAL TO ONE. */
ibig = idamax_(mrows, &w[j * w_dim1 + 1], &c__1);
rw[j] = (d__1 = w[ibig + j * w_dim1], abs(d__1));
if (rw[j] == zero) {
rw[j] = one;
} else {
rw[j] = one / rw[j];
}
goto L140;
L110:
/* CASE 2 */
/* THIS CHOICE OF SCALING MAKES EACH NONZERO COLUMN */
/* HAVE EUCLIDEAN LENGTH EQUAL TO ONE. */
rw[j] = dnrm2_(mrows, &w[j * w_dim1 + 1], &c__1);
if (rw[j] == zero) {
rw[j] = one;
} else {
rw[j] = one / rw[j];
}
goto L140;
L120:
/* CASE 3 */
/* THIS CASE EFFECTIVELY SUPPRESSES SCALING BY SETTING */
/* THE SCALING MATRIX TO THE IDENTITY MATRIX. */
rw[1] = one;
dcopy_(ncols, &rw[1], &c__0, &rw[1], &c__1);
goto L160;
L130:
/* CASE 4 */
goto L160;
L140:
/* L150: */
;
}
L160:
/* END PROCEDURE */
/* DO(SOLVE BOUNDED LEAST SQUARES PROBLEM) */
/* PROCEDURE(SOLVE BOUNDED LEAST SQUARES PROBLEM) */
/* INITIALIZE IBASIS(*), J=1,NCOLS, AND IBB(*), J=1,NCOLS, */
/* TO =J,AND =1, FOR USE IN DBOLSM( ). */
i__1 = *ncols;
for (j = 1; j <= i__1; ++j) {
iw[j] = j;
iw[j + *ncols] = 1;
rw[*ncols * 3 + j] = bl[j];
rw[(*ncols << 2) + j] = bu[j];
/* L170: */
}
dbolsm_(&w[w_offset], mdw, mrows, ncols, &rw[*ncols * 3 + 1], &rw[(*ncols
<< 2) + 1], &ind[1], &iopt[lopt], &x[1], rnorm, mode, &rw[*ncols
+ 1], &rw[(*ncols << 1) + 1], &rw[1], &iw[1], &iw[*ncols + 1]);
/* END PROCEDURE */
igo = 0;
L180:
return 0;
/* PROCEDURE(RETURN TO USER PROGRAM UNIT) */
L190:
if (*mode >= 0) {
*mode = -nerr;
}
igo = 0;
return 0;
/* END PROCEDURE */
} /* dbols_ */
/* Subroutine */ int check0_(doublereal *sfac)
{
/* Initialized data */
static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
/* Local variables */
integer k;
doublereal sa, sb, sc, ss;
/* Fortran I/O blocks */
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Subroutines .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
/* Compute true values which cannot be prestored */
/* in decimal notation */
dbtrue[0] = 1.6666666666666667;
dbtrue[2] = -1.6666666666666667;
dbtrue[4] = 1.6666666666666667;
for (k = 1; k <= 8; ++k) {
/* .. Set N=K for identification in output if any .. */
combla_1.n = k;
if (combla_1.icase == 3) {
/* .. DROTG .. */
if (k > 8) {
goto L40;
}
sa = da1[k - 1];
sb = db1[k - 1];
drotg_(&sa, &sb, &sc, &ss);
stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
} else {
s_wsle(&io___18);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L20: */
}
L40:
return 0;
} /* check0_ */
