/* 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_ */
/* Subroutine */ int dneigh_(doublereal *rnorm, integer *n, doublereal *h__,
integer *ldh, doublereal *ritzr, doublereal *ritzi, doublereal *
bounds, doublereal *q, integer *ldq, doublereal *workl, integer *ierr)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
static integer i__;
static real t0, t1;
static doublereal vl[1], temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer iconj;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dmout_(integer *,
integer *, integer *, doublereal *, integer *, integer *, char *,
ftnlen), dvout_(integer *, integer *, doublereal *, integer *,
char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlaqrb_(logical *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *), second_(real *);
static logical select[1];
static integer msglvl;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
dtrevc_(char *, char *, logical *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, ftnlen, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/* Parameter adjustments */
--workl;
--bounds;
--ritzi;
--ritzr;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
second_(&t0);
msglvl = debug_1.mneigh;
if (msglvl > 2) {
dmout_(&debug_1.logfil, n, n, &h__[h_offset], ldh, &debug_1.ndigit,
"_neigh: Entering upper Hessenberg matrix H ", (ftnlen)43);
}
/* %-----------------------------------------------------------% */
/* | 1. Compute the eigenvalues, the last components of the | */
/* | corresponding Schur vectors and the full Schur form T | */
/* | of the current upper Hessenberg matrix H. | */
/* | dlaqrb returns the full Schur form of H in WORKL(1:N**2) | */
/* | and the last components of the Schur vectors in BOUNDS. | */
/* %-----------------------------------------------------------% */
dlacpy_("All", n, n, &h__[h_offset], ldh, &workl[1], n, (ftnlen)3);
dlaqrb_(&c_true, n, &c__1, n, &workl[1], n, &ritzr[1], &ritzi[1], &bounds[
1], ierr);
if (*ierr != 0) {
goto L9000;
}
if (msglvl > 1) {
dvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: las"
"t row of the Schur matrix for H", (ftnlen)42);
}
/* %-----------------------------------------------------------% */
/* | 2. Compute the eigenvectors of the full Schur form T and | */
/* | apply the last components of the Schur vectors to get | */
/* | the last components of the corresponding eigenvectors. | */
/* | Remember that if the i-th and (i+1)-st eigenvalues are | */
/* | complex conjugate pairs, then the real & imaginary part | */
/* | of the eigenvector components are split across adjacent | */
/* | columns of Q. | */
/* %-----------------------------------------------------------% */
dtrevc_("R", "A", select, n, &workl[1], n, vl, n, &q[q_offset], ldq, n, n,
&workl[*n * *n + 1], ierr, (ftnlen)1, (ftnlen)1);
if (*ierr != 0) {
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | euclidean norms are all one. LAPACK subroutine | */
/* | dtrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; here the magnitude of a complex | */
/* | number (x,y) is taken to be |x| + |y|. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = ritzi[i__], abs(d__1)) <= 0.) {
/* %----------------------% */
/* | Real eigenvalue case | */
/* %----------------------% */
temp = dnrm2_(n, &q[i__ * q_dim1 + 1], &c__1);
d__1 = 1. / temp;
dscal_(n, &d__1, &q[i__ * q_dim1 + 1], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
d__1 = dnrm2_(n, &q[i__ * q_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &q[(i__ + 1) * q_dim1 + 1], &c__1);
temp = dlapy2_(&d__1, &d__2);
d__1 = 1. / temp;
dscal_(n, &d__1, &q[i__ * q_dim1 + 1], &c__1);
d__1 = 1. / temp;
dscal_(n, &d__1, &q[(i__ + 1) * q_dim1 + 1], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L10: */
}
dgemv_("T", n, n, &c_b18, &q[q_offset], ldq, &bounds[1], &c__1, &c_b20, &
workl[1], &c__1, (ftnlen)1);
if (msglvl > 1) {
dvout_(&debug_1.logfil, n, &workl[1], &debug_1.ndigit, "_neigh: Last"
" row of the eigenvector matrix for H", (ftnlen)48);
}
/* %----------------------------% */
/* | Compute the Ritz estimates | */
/* %----------------------------% */
iconj = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = ritzi[i__], abs(d__1)) <= 0.) {
/* %----------------------% */
/* | Real eigenvalue case | */
/* %----------------------% */
bounds[i__] = *rnorm * (d__1 = workl[i__], abs(d__1));
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we need to take the magnitude | */
/* | of the last components of the two vectors | */
/* %-------------------------------------------% */
if (iconj == 0) {
bounds[i__] = *rnorm * dlapy2_(&workl[i__], &workl[i__ + 1]);
bounds[i__ + 1] = bounds[i__];
iconj = 1;
} else {
iconj = 0;
}
}
/* L20: */
}
if (msglvl > 2) {
dvout_(&debug_1.logfil, n, &ritzr[1], &debug_1.ndigit, "_neigh: Real"
" part of the eigenvalues of H", (ftnlen)41);
dvout_(&debug_1.logfil, n, &ritzi[1], &debug_1.ndigit, "_neigh: Imag"
"inary part of the eigenvalues of H", (ftnlen)46);
dvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: Rit"
"z estimates for the eigenvalues of H", (ftnlen)47);
}
second_(&t1);
timing_1.tneigh += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of dneigh | */
/* %---------------% */
} /* dneigh_ */
