*DECK S1MERG
      SUBROUTINE S1MERG (TCOS, I1, M1, I2, M2, I3)
C***BEGIN PROLOGUE  S1MERG
C***SUBSIDIARY
C***PURPOSE  Merge two strings of ascending real numbers.
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   This subroutine merges two ascending strings of numbers in the
C   array TCOS.  The first string is of length M1 and starts at
C   TCOS(I1+1).  The second string is of length M2 and starts at
C   TCOS(I2+1).  The merged string goes into TCOS(I3+1).
C
C***SEE ALSO  GENBUN
C***ROUTINES CALLED  SCOPY
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C   901120  Modified to use IF-THEN-ELSE.  Previous spaghetti code did
C           not compile correctly with optimization on the IBM RS6000.
C           (RWC)
C   920130  Code name changed from MERGE to S1MERG.  (WRB)
C***END PROLOGUE  S1MERG
      INTEGER I1, I2, I3, M1, M2
      REAL TCOS(*)
C
      INTEGER J1, J2, J3
C
C***FIRST EXECUTABLE STATEMENT  S1MERG
      IF (M1.EQ.0 .AND. M2.EQ.0) RETURN
C
      IF (M1.EQ.0 .AND. M2.NE.0) THEN
         CALL SCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1)
         RETURN
      ENDIF
C
      IF (M1.NE.0 .AND. M2.EQ.0) THEN
         CALL SCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1)
         RETURN
      ENDIF
C
      J1 = 1
      J2 = 1
      J3 = 1
C
   10 IF (TCOS(I1+J1) .LE. TCOS(I2+J2)) THEN
         TCOS(I3+J3) = TCOS(I1+J1)
         J1 = J1+1
         IF (J1 .GT. M1) THEN
            CALL SCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1)
            RETURN
         ENDIF
      ELSE
         TCOS(I3+J3) = TCOS(I2+J2)
         J2 = J2+1
         IF (J2 .GT. M2) THEN
            CALL SCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1)
            RETURN
         ENDIF
      ENDIF
      J3 = J3+1
      GO TO 10
      END
*DECK SBCG
      SUBROUTINE SBCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
     +   MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z,
     +   P, RR, ZZ, PP, DZ, RWORK, IWORK)
C***BEGIN PROLOGUE  SBCG
C***PURPOSE  Preconditioned BiConjugate Gradient Sparse Ax = b Solver.
C            Routine to solve a Non-Symmetric linear system  Ax = b
C            using the Preconditioned BiConjugate Gradient method.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2A4, D2B4
C***TYPE      SINGLE PRECISION (SBCG-S, DBCG-D)
C***KEYWORDS  BICONJUGATE GRADIENT, ITERATIVE PRECONDITION,
C             NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE
C***AUTHOR  Greenbaum, Anne, (Courant Institute)
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C             seager@llnl.gov
C***DESCRIPTION
C
C *Usage:
C      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C      INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED)
C      REAL    B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), P(N)
C      REAL    RR(N), ZZ(N), PP(N), DZ(N)
C      REAL    RWORK(USER DEFINED)
C      EXTERNAL MATVEC, MTTVEC, MSOLVE, MTSOLV
C
C      CALL SBCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
C     $     MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
C     $     R, Z, P, RR, ZZ, PP, DZ, RWORK, IWORK)
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Real B(N).
C         Right-hand side vector.
C X      :INOUT    Real X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Real A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "Description", below, for more
C         details.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all non-zero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which  performs the matrix vector multiply
C         operation  Y = A*X  given A and X.  The  name of  the MATVEC
C         routine must  be declared external  in the  calling program.
C         The calling sequence of MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X upon
C         return,  X is an input  vector.  NELT, IA,  JA,  A and  ISYM
C         define the SLAP matrix data structure: see Description,below.
C MTTVEC :EXT      External.
C         Name of a routine which performs the matrix transpose vector
C         multiply y = A'*X given A and X (where ' denotes transpose).
C         The name of the MTTVEC routine must be declared external  in
C         the calling program.  The calling sequence to MTTVEC is  the
C         same as that for MTTVEC, viz.:
C             CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N  is the number  of unknowns, Y is the   product A'*X
C         upon return, X is an input vector.  NELT, IA, JA, A and ISYM
C         define the SLAP matrix data structure: see Description,below.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R  for Z
C         given R with the preconditioning matrix M (M is supplied via
C         RWORK  and IWORK arrays).   The name  of  the MSOLVE routine
C         must be declared  external  in the  calling   program.   The
C         calling sequence of MSOLVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is  the right-hand side
C         vector, and Z is the solution upon return.  NELT,  IA, JA, A
C         and  ISYM define the SLAP  matrix  data structure: see
C         Description, below.  RWORK is a  real array that can be used
C         to  pass   necessary  preconditioning     information and/or
C         workspace to MSOLVE.  IWORK is an integer work array for the
C         same purpose as RWORK.
C MTSOLV :EXT      External.
C         Name of a routine which solves a linear system M'ZZ = RR for
C         ZZ given RR with the preconditioning matrix M (M is supplied
C         via RWORK and IWORK arrays).  The name of the MTSOLV routine
C         must be declared external in the calling program.  The call-
C         ing sequence to MTSOLV is:
C            CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, RR is the right-hand side
C         vector, and ZZ is the solution upon return.  NELT, IA, JA, A
C         and  ISYM define the SLAP  matrix  data structure: see
C         Description, below.  RWORK is a  real array that can be used
C         to  pass   necessary  preconditioning     information and/or
C         workspace to MTSOLV.  IWORK is an integer work array for the
C         same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C             COMMON /SSLBLK/ SOLN( )
C         If ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :INOUT    Real.
C         Convergence criterion, as described above.  (Reset if IERR=4.)
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Real.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient space allocated for WORK or IWORK.
C           IERR = 2 => Method failed to converge in ITMAX steps.
C           IERR = 3 => Error in user input.
C                       Check input values of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500*R1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M, is not positive
C                       definite.  (r,z) < 0.
C           IERR = 6 => Matrix A is not positive definite.  (p,Ap) < 0.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :WORK     Real R(N).
C Z      :WORK     Real Z(N).
C P      :WORK     Real P(N).
C RR     :WORK     Real RR(N).
C ZZ     :WORK     Real ZZ(N).
C PP     :WORK     Real PP(N).
C DZ     :WORK     Real DZ(N).
C         Real arrays used for workspace.
C RWORK  :WORK     Real RWORK(USER DEFINED).
C         Real array that can be used for workspace in MSOLVE
C         and MTSOLV.
C IWORK  :WORK     Integer IWORK(USER DEFINED).
C         Integer array that can be used for workspace in MSOLVE
C         and MTSOLV.
C
C *Description
C      This routine does not care what matrix data structure is used
C       for A and M.  It simply calls MATVEC, MTTVEC, MSOLVE, MTSOLV
C       routines, with arguments as above.  The user could write any
C       type of structure, and  appropriate  MATVEC, MSOLVE, MTTVEC,
C       and MTSOLV routines.  It  is assumed that A is stored in the
C       IA, JA, A  arrays in some fashion and  that M (or INV(M)) is
C       stored  in  IWORK  and  RWORK   in  some fashion.   The SLAP
C       routines SSDBCG and SSLUBC are examples of this procedure.
C
C       Two  examples  of  matrix  data structures  are the: 1) SLAP
C       Triad  format and 2) SLAP Column format.
C
C       =================== S L A P Triad format ===================
C       In  this   format only the  non-zeros are  stored.  They may
C       appear  in *ANY* order.   The user  supplies three arrays of
C       length NELT, where  NELT  is the number  of non-zeros in the
C       matrix:  (IA(NELT), JA(NELT),  A(NELT)).  For each  non-zero
C       the  user puts   the row  and  column index   of that matrix
C       element in the IA and JA arrays.  The  value of the non-zero
C       matrix  element is  placed in  the corresponding location of
C       the A  array.  This is  an extremely easy data  structure to
C       generate.  On  the other hand it  is  not too  efficient  on
C       vector  computers   for the  iterative  solution  of  linear
C       systems.  Hence, SLAP  changes this input  data structure to
C       the SLAP   Column  format for the  iteration (but   does not
C       change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix      SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C
C       In  this format   the non-zeros are    stored counting  down
C       columns (except  for the diagonal  entry, which must  appear
C       first in each "column") and are  stored in the real array A.
C       In other words,  for  each column    in the matrix   put the
C       diagonal  entry  in A.   Then   put  in the  other  non-zero
C       elements going   down the  column (except  the  diagonal) in
C       order.  The IA array holds the row index  for each non-zero.
C       The JA array holds the offsets into the IA, A arrays for the
C       beginning   of   each  column.      That is,   IA(JA(ICOL)),
C       A(JA(ICOL)) points to the beginning of the ICOL-th column in
C       IA and  A.  IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1)  points to the
C       end of the ICOL-th column.  Note that we always have JA(N+1)
C       = NELT+1, where N is the number of columns in the matrix and
C       NELT is the number of non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Cautions:
C     This routine will attempt to write to the Fortran logical output
C     unit IUNIT, if IUNIT .ne. 0.  Thus, the user must make sure that
C     this logical unit is attached to a file or terminal before calling
C     this routine with a non-zero value for IUNIT.  This routine does
C     not check for the validity of a non-zero IUNIT unit number.
C
C***SEE ALSO  SSDBCG, SSLUBC
C***REFERENCES  1. Mark K. Seager, A SLAP for the Masses, in
C                  G. F. Carey, Ed., Parallel Supercomputing: Methods,
C                  Algorithms and Applications, Wiley, 1989, pp.135-155.
C***ROUTINES CALLED  ISSBCG, R1MACH, SAXPY, SCOPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   871119  DATE WRITTEN
C   881213  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890921  Removed TeX from comments.  (FNF)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   891004  Added new reference.
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   910502  Removed MATVEC, MTTVEC, MSOLVE, MTSOLV from ROUTINES
C           CALLED list.  (FNF)
C   920407  COMMON BLOCK renamed SSLBLK.  (WRB)
C   920511  Added complete declaration section.  (WRB)
C   920929  Corrected format of reference.  (FNF)
C   921019  Changed 500.0 to 500 to reduce SP/DP differences.  (FNF)
C   921113  Corrected C***CATEGORY line.  (FNF)
C***END PROLOGUE  SBCG
C     .. Scalar Arguments ..
      REAL ERR, TOL
      INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT
C     .. Array Arguments ..
      REAL A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), RWORK(*),
     +     X(N), Z(N), ZZ(N)
      INTEGER IA(NELT), IWORK(*), JA(NELT)
C     .. Subroutine Arguments ..
      EXTERNAL MATVEC, MSOLVE, MTSOLV, MTTVEC
C     .. Local Scalars ..
      REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, FUZZ, SOLNRM, TOLMIN
      INTEGER I, K
C     .. External Functions ..
      REAL R1MACH, SDOT
      INTEGER ISSBCG
      EXTERNAL R1MACH, SDOT, ISSBCG
C     .. External Subroutines ..
      EXTERNAL SAXPY, SCOPY
C     .. Intrinsic Functions ..
      INTRINSIC ABS
C***FIRST EXECUTABLE STATEMENT  SBCG
C
C         Check some of the input data.
C
      ITER = 0
      IERR = 0
      IF( N.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      FUZZ = R1MACH(3)
      TOLMIN = 500*FUZZ
      FUZZ = FUZZ*FUZZ
      IF( TOL.LT.TOLMIN ) THEN
         TOL = TOLMIN
         IERR = 4
      ENDIF
C
C         Calculate initial residual and pseudo-residual, and check
C         stopping criterion.
      CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM)
      DO 10 I = 1, N
         R(I)  = B(I) - R(I)
         RR(I) = R(I)
 10   CONTINUE
      CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
      CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
      IF( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP,
     $     DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $     GO TO 200
      IF( IERR.NE.0 ) RETURN
C
C         ***** iteration loop *****
C
      DO 100 K=1,ITMAX
         ITER = K
C
C         Calculate coefficient BK and direction vectors P and PP.
         BKNUM = SDOT(N, Z, 1, RR, 1)
         IF( ABS(BKNUM).LE.FUZZ ) THEN
            IERR = 6
            RETURN
         ENDIF
         IF(ITER .EQ. 1) THEN
            CALL SCOPY(N, Z, 1, P, 1)
            CALL SCOPY(N, ZZ, 1, PP, 1)
         ELSE
            BK = BKNUM/BKDEN
            DO 20 I = 1, N
               P(I) = Z(I) + BK*P(I)
               PP(I) = ZZ(I) + BK*PP(I)
 20         CONTINUE
         ENDIF
         BKDEN = BKNUM
C
C         Calculate coefficient AK, new iterate X, new residuals R and
C         RR, and new pseudo-residuals Z and ZZ.
         CALL MATVEC(N, P, Z, NELT, IA, JA, A, ISYM)
         AKDEN = SDOT(N, PP, 1, Z, 1)
         AK = BKNUM/AKDEN
         IF( ABS(AKDEN).LE.FUZZ ) THEN
            IERR = 6
            RETURN
         ENDIF
         CALL SAXPY(N, AK, P, 1, X, 1)
         CALL SAXPY(N, -AK, Z, 1, R, 1)
         CALL MTTVEC(N, PP, ZZ, NELT, IA, JA, A, ISYM)
         CALL SAXPY(N, -AK, ZZ, 1, RR, 1)
         CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
         CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
C         check stopping criterion.
         IF( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL,
     $        ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ,
     $        PP, DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $        GO TO 200
C
 100  CONTINUE
C
C         *****   end of loop  *****
C
C         stopping criterion not satisfied.
      ITER = ITMAX + 1
      IERR = 2
C
 200  RETURN
C------------- LAST LINE OF SBCG FOLLOWS ----------------------------
      END
*DECK SBHIN
      SUBROUTINE SBHIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB)
C***BEGIN PROLOGUE  SBHIN
C***PURPOSE  Read a Sparse Linear System in the Boeing/Harwell Format.
C            The matrix is read in and if the right hand side is also
C            present in the input file then it too is read in.  The
C            matrix is then modified to be in the SLAP Column format.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  N1
C***TYPE      SINGLE PRECISION (SBHIN-S, DBHIN-D)
C***KEYWORDS  LINEAR SYSTEM, MATRIX READ, SLAP SPARSE
C***AUTHOR  Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C             seager@llnl.gov
C***DESCRIPTION
C
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB
C     REAL    A(NELT), SOLN(N), RHS(N)
C
C     CALL SBHIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB )
C
C *Arguments:
C N      :OUT      Integer
C         Order of the Matrix.
C NELT   :INOUT    Integer.
C         On input NELT is the maximum number of non-zeros that
C         can be stored in the IA, JA, A arrays.
C         On output NELT is the number of non-zeros stored in A.
C IA     :OUT      Integer IA(NELT).
C JA     :OUT      Integer JA(NELT).
C A      :OUT      Real A(NELT).
C         On output these arrays hold the matrix A in the SLAP
C         Triad format.  See "Description", below.
C ISYM   :OUT      Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all non-zero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the lower
C         triangle of the matrix is stored.
C SOLN   :OUT      Real SOLN(N).
C         The solution to the linear system, if present.  This array
C         is accessed if and only if JOB is set to read it in, see
C         below.  If the user requests that SOLN be read in, but it is
C         not in the file, then it is simply zeroed out.
C RHS    :OUT      Real RHS(N).
C         The right hand side vector.  This array is accessed if and
C         only if JOB is set to read it in, see below.
C         If the user requests that RHS be read in, but it is not in
C         the file, then it is simply zeroed out.
C IUNIT  :IN       Integer.
C         Fortran logical I/O device unit number to read the matrix
C         from.  This unit must be connected in a system dependent
C         fashion to a file, or you will get a nasty message
C         from the Fortran I/O libraries.
C JOB    :INOUT    Integer.
C         Flag indicating what I/O operations to perform.
C         On input JOB indicates what Input operations to try to
C         perform.
C         JOB = 0 => Read only the matrix.
C         JOB = 1 => Read matrix and RHS (if present).
C         JOB = 2 => Read matrix and SOLN (if present).
C         JOB = 3 => Read matrix, RHS and SOLN (if present).
C         On output JOB indicates what operations were actually
C         performed.
C         JOB = -3 => Unable to parse matrix "CODE" from input file
C                     to determine if only the lower triangle of matrix
C                     is stored.
C         JOB = -2 => Number of non-zeros (NELT) too large.
C         JOB = -1 => System size (N) too large.
C         JOB =  0 => Read in only the matrix.
C         JOB =  1 => Read in the matrix and RHS.
C         JOB =  2 => Read in the matrix and SOLN.
C         JOB =  3 => Read in the matrix, RHS and SOLN.
C         JOB = 10 => Read in only the matrix *STRUCTURE*, but no
C                     non-zero entries.  Hence, A(*) is not referenced
C                     and has the return values the same as the input.
C         JOB = 11 => Read in the matrix *STRUCTURE* and RHS.
C         JOB = 12 => Read in the matrix *STRUCTURE* and SOLN.
C         JOB = 13 => Read in the matrix *STRUCTURE*, RHS and SOLN.
C
C *Description:
C       The format for the input is as follows.  The first line contains
C       a title to identify the data file.  On the second line (5I4) are
C       counters: NLINE, NPLS, NRILS, NNVLS, NRHSLS.
C        NLINE  Number of data lines (after the header) in the file.
C        NPLS   Number of lines for the Column Pointer data in the file.
C        NRILS  Number of lines for the Row indices in the file.
C        NNVLS  Number of lines for the Matrix elements in the file.
C        NRHSLS Number of lines for the RHS in the file.
C       The third line (A3,11X,4I4) contains a symmetry code and some
C       additional counters: CODE, NROW, NCOL, NIND, NELE.
C       On the fourth line (2A16,2A20) are formats to be used to read
C       the following data: PNTFNT, RINFMT, NVLFMT, RHSFMT.
C       Following that are the blocks of data in the order indicated.
C
C       =================== S L A P Triad format ===================
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero  matrix  element is  placed   in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix      SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Portability:
C         You must make sure that IUNIT is a valid Fortran logical
C         I/O device unit number and that the unit number has been
C         associated with a file or the console.  This is a system
C         dependent function.
C
C *Implementation note:
C         SOLN is not read by this version.  It will simply be
C         zeroed out if JOB = 2 or 3 and the returned value of
C         JOB will indicate SOLN has not been read.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   881107  DATE WRITTEN
C   881213  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   911122  Added loop to zero out RHS if user wants to read RHS, but
C           it's not in the input file. (MKS)
C   911125  Minor improvements to prologue.  (FNF)
C   920511  Added complete declaration section.  (WRB)
C   921007  Corrected description of input format.  (FNF)
C   921208  Added Implementation Note and code to zero out SOLN.  (FNF)
C   930701  Updated CATEGORY section.  (FNF, WRB)
C***END PROLOGUE  SBHIN
C     .. Scalar Arguments ..
      INTEGER ISYM, IUNIT, JOB, N, NELT
C     .. Array Arguments ..
      REAL A(NELT), RHS(N), SOLN(N)
      INTEGER IA(NELT), JA(NELT)
C     .. Local Scalars ..
      REAL TEMP
      INTEGER I, IBGN, ICOL, IEND, ITEMP, J, JOBRET, NCOL, NELE, NIND,
     +        NLINE, NNVLS, NPLS, NRHSLS, NRILS, NROW
      CHARACTER CODE*3, PNTFMT*16, RINFMT*16, NVLFMT*20, RHSFMT*20,
     +          TITLE*80
C     .. Intrinsic Functions ..
      INTRINSIC MOD
C***FIRST EXECUTABLE STATEMENT  SBHIN
C
C         Read Matrices In BOEING-HARWELL format.
C
C TITLE  Header line to identify data file.
C NLINE  Number of data lines (after the header) in the file.
C NPLS   Number of lines for the Column Pointer data in the file.
C NRILS  Number of lines for the Row indices in the data file.
C NNVLS  Number of lines for the Matrix elements in the data file.
C NRHSLS Number of lines for the RHS in the data file.
C ---- Only those variables needed by SLAP are referenced. ----
C
      READ(IUNIT,9000) TITLE
      READ(IUNIT,9010) NLINE, NPLS, NRILS, NNVLS, NRHSLS
      READ(IUNIT,9020) CODE, NROW, NCOL, NIND, NELE
      READ(IUNIT,9030) PNTFMT, RINFMT, NVLFMT, RHSFMT
C
      IF( NROW.GT.N ) THEN
         N = NROW
         JOBRET = -1
         GOTO 999
      ENDIF
      IF( NIND.GT.NELT ) THEN
         NELT = NIND
         JOBRET = -2
         GOTO 999
      ENDIF
C
C         Set the parameters.
C
      N    = NROW
      NELT = NIND
      IF( CODE.EQ.'RUA' ) THEN
         ISYM = 0
      ELSE IF( CODE.EQ.'RSA' ) THEN
         ISYM = 1
      ELSE
         JOBRET = -3
         GOTO 999
      ENDIF
      READ(IUNIT,PNTFMT) (JA(I), I = 1, N+1)
      READ(IUNIT,RINFMT) (IA(I), I = 1, NELT)
      JOBRET = 10
      IF( NNVLS.GT.0 ) THEN
         READ(IUNIT,NVLFMT) (A(I),  I = 1, NELT)
         JOBRET = 0
      ENDIF
      IF( MOD(JOB,2).EQ.1 ) THEN
C
C         User requests that the RHS be read in.  If it is in the input
C         file, read it in; otherwise just zero it out.
C
         IF( NRHSLS.GT.0 ) THEN
            READ(5,RHSFMT) (RHS(I), I = 1, N)
            JOBRET = JOBRET + 1
         ELSE
            DO 10 I = 1, N
               RHS(I) = 0
 10         CONTINUE
         ENDIF
      ENDIF
      IF ( (JOB.EQ.2).OR.(JOB.EQ.3) ) THEN
C
C         User requests that the SOLN be read in.
C         Just zero out the array.
C
         DO 20 I = 1, N
            SOLN(I) = 0
 20      CONTINUE
      ENDIF
C
C         Now loop through the IA array making sure that the diagonal
C         matrix element appears first in the column.  Then sort the
C         rest of the column in ascending order.
C
CVD$R NOCONCUR
CVD$R NOVECTOR
      DO 70 ICOL = 1, N
         IBGN = JA(ICOL)
         IEND = JA(ICOL+1)-1
         DO 30 I = IBGN, IEND
            IF( IA(I).EQ.ICOL ) THEN
C
C              Swap the diagonal element with the first element in the
C              column.
C
               ITEMP = IA(I)
               IA(I) = IA(IBGN)
               IA(IBGN) = ITEMP
               TEMP = A(I)
               A(I) = A(IBGN)
               A(IBGN) = TEMP
               GOTO 40
            ENDIF
 30      CONTINUE
 40      IBGN = IBGN + 1
         IF( IBGN.LT.IEND ) THEN
            DO 60 I = IBGN, IEND
               DO 50 J = I+1, IEND
                  IF( IA(I).GT.IA(J) ) THEN
                     ITEMP = IA(I)
                     IA(I) = IA(J)
                     IA(J) = ITEMP
                     TEMP = A(I)
                     A(I) = A(J)
                     A(J) = TEMP
                  ENDIF
 50            CONTINUE
 60         CONTINUE
         ENDIF
 70   CONTINUE
C
C         Set return flag.
 999  JOB = JOBRET
      RETURN
 9000 FORMAT( A80 )
 9010 FORMAT( 5I14 )
 9020 FORMAT( A3, 11X, 4I14 )
 9030 FORMAT( 2A16, 2A20 )
C------------- LAST LINE OF SBHIN FOLLOWS ------------------------------
      END
*DECK SBOCLS
      SUBROUTINE SBOCLS (W, MDW, MCON, MROWS, NCOLS, BL, BU, IND, IOPT,
     +   X, RNORMC, RNORM, MODE, RW, IW)
C***BEGIN PROLOGUE  SBOCLS
C***PURPOSE  Solve the bounded and constrained least squares
C            problem consisting of solving the equation
C                      E*X = F  (in the least squares sense)
C             subject to the linear constraints
C                            C*X = Y.
C***LIBRARY   SLATEC
C***CATEGORY  K1A2A, G2E, G2H1, G2H2
C***TYPE      SINGLE PRECISION (SBOCLS-S, DBOCLS-D)
C***KEYWORDS  BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     This subprogram solves the bounded and constrained least squares
C     problem. The problem statement is:
C
C     Solve E*X = F (least squares sense), subject to constraints
C     C*X=Y.
C
C     In this formulation both X and Y are unknowns, and both may
C     have bounds on any of their components.  This formulation
C     of the problem allows the user to have equality and inequality
C     constraints as well as simple bounds on the solution components.
C
C     This constrained linear least squares subprogram solves E*X=F
C     subject to C*X=Y, where E is MROWS by NCOLS, C is MCON by NCOLS.
C
C      The user must have dimension statements of the form
C
C      DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON), BU(NCOLS+MCON),
C     * X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON)
C       INTEGER IND(NCOLS+MCON), IOPT(17+NI), IW(2*(NCOLS+MCON))
C
C     (here NX=number of extra locations required for the options; NX=0
C     if no options are in use. Also NI=number of extra locations
C     for options 1-9.)
C
C    INPUT
C    -----
C
C    -------------------------
C    W(MDW,*),MCON,MROWS,NCOLS
C    -------------------------
C     The array W contains the (possibly null) matrix [C:*] followed by
C     [E:F].  This must be placed in W as follows:
C          [C  :  *]
C     W  = [       ]
C          [E  :  F]
C     The (*) after C indicates that this data can be undefined. The
C     matrix [E:F] has MROWS rows and NCOLS+1 columns. The matrix C is
C     placed in the first MCON rows of W(*,*) while [E:F]
C     follows in rows MCON+1 through MCON+MROWS of W(*,*). The vector F
C     is placed in rows MCON+1 through MCON+MROWS, column NCOLS+1. The
C     values of MDW and NCOLS must be positive; the value of MCON must
C     be nonnegative. An exception to this occurs when using option 1
C     for accumulation of blocks of equations. In that case MROWS is an
C     OUTPUT variable only, and the matrix data for [E:F] is placed in
C     W(*,*), one block of rows at a time. See IOPT(*) contents, option
C     number 1, for further details. The row dimension, MDW, of the
C     array W(*,*) must satisfy the inequality:
C
C     If using option 1,
C                     MDW .ge. MCON + max(max. number of
C                     rows accumulated, NCOLS) + 1.
C     If using option 8,
C                     MDW .ge. MCON + MROWS.
C     Else
C                     MDW .ge. MCON + max(MROWS, NCOLS).
C
C     Other values are errors, but this is checked only when using
C     option=2.  The value of MROWS is an output parameter when
C     using option number 1 for accumulating large blocks of least
C     squares equations before solving the problem.
C     See IOPT(*) contents for details about option 1.
C
C    ------------------
C    BL(*),BU(*),IND(*)
C    ------------------
C     These arrays contain the information about the bounds that the
C     solution values are to satisfy. The value of IND(J) tells the
C     type of bound and BL(J) and BU(J) give the explicit values for
C     the respective upper and lower bounds on the unknowns X and Y.
C     The first NVARS entries of IND(*), BL(*) and BU(*) specify
C     bounds on X; the next MCON entries specify bounds on Y.
C
C    1.    For IND(J)=1, require X(J) .ge. BL(J);
C          IF J.gt.NCOLS,        Y(J-NCOLS) .ge. BL(J).
C          (the value of BU(J) is not used.)
C    2.    For IND(J)=2, require X(J) .le. BU(J);
C          IF J.gt.NCOLS,        Y(J-NCOLS) .le. BU(J).
C          (the value of BL(J) is not used.)
C    3.    For IND(J)=3, require X(J) .ge. BL(J) and
C                                X(J) .le. BU(J);
C          IF J.gt.NCOLS,        Y(J-NCOLS) .ge. BL(J) and
C                                Y(J-NCOLS) .le. BU(J).
C          (to impose equality constraints have BL(J)=BU(J)=
C          constraining value.)
C    4.    For IND(J)=4, no bounds on X(J) or Y(J-NCOLS) are required.
C          (the values of BL(J) and BU(J) are not used.)
C
C     Values other than 1,2,3 or 4 for IND(J) are errors. In the case
C     IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J)
C     is  an  error.   The values BL(J), BU(J), J .gt. NCOLS, will be
C     changed.  Significant changes mean that the constraints are
C     infeasible.  (Users must make this decision themselves.)
C     The new values for BL(J), BU(J), J .gt. NCOLS, define a
C     region such that the perturbed problem is feasible.  If users
C     know that their problem is feasible, this step can be skipped
C     by using option number 8 described below.
C
C     See IOPT(*) description.
C
C
C    -------
C    IOPT(*)
C    -------
C     This is the array where the user can specify nonstandard options
C     for SBOCLS( ). Most of the time this feature can be ignored by
C     setting the input value IOPT(1)=99. Occasionally users may have
C     needs that require use of the following subprogram options. For
C     details about how to use the options see below: IOPT(*) CONTENTS.
C
C     Option Number   Brief Statement of Purpose
C     ------ ------   ----- --------- -- -------
C           1         Return to user for accumulation of blocks
C                     of least squares equations.  The values
C                     of IOPT(*) are changed with this option.
C                     The changes are updates to pointers for
C                     placing the rows of equations into position
C                     for processing.
C           2         Check lengths of all arrays used in the
C                     subprogram.
C           3         Column scaling of the data matrix, [C].
C                                                        [E]
C           4         User provides column scaling for matrix [C].
C                                                             [E]
C           5         Provide option array to the low-level
C                     subprogram SBOLS( ).
C           6         Provide option array to the low-level
C                     subprogram SBOLSM( ).
C           7         Move the IOPT(*) processing pointer.
C           8         Do not preprocess the constraints to
C                     resolve infeasibilities.
C           9         Do not pretriangularize the least squares matrix.
C          99         No more options to change.
C
C    ----
C    X(*)
C    ----
C     This array is used to pass data associated with options 4,5 and
C     6. Ignore this parameter (on input) if no options are used.
C     Otherwise see below: IOPT(*) CONTENTS.
C
C
C    OUTPUT
C    ------
C
C    -----------------
C    X(*),RNORMC,RNORM
C    -----------------
C     The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for
C     the constrained least squares problem. The value RNORMC is the
C     minimum residual vector length for the constraints C*X - Y = 0.
C     The value RNORM is the minimum residual vector length for the
C     least squares equations. Normally RNORMC=0, but in the case of
C     inconsistent constraints this value will be nonzero.
C     The values of X are returned in the first NVARS entries of X(*).
C     The values of Y are returned in the last MCON entries of X(*).
C
C    ----
C    MODE
C    ----
C     The sign of MODE determines whether the subprogram has completed
C     normally, or encountered an error condition or abnormal status. A
C     value of MODE .ge. 0 signifies that the subprogram has completed
C     normally. The value of mode (.ge. 0) is the number of variables
C     in an active status: not at a bound nor at the value zero, for
C     the case of free variables. A negative value of MODE will be one
C     of the cases (-57)-(-41), (-37)-(-22), (-19)-(-2). Values .lt. -1
C     correspond to an abnormal completion of the subprogram. These
C     error messages are in groups for the subprograms SBOCLS(),
C     SBOLSM(), and SBOLS().  An approximate solution will be returned
C     to the user only when max. iterations is reached, MODE=-22.
C
C    -----------
C    RW(*),IW(*)
C    -----------
C     These are working arrays.  (normally the user can ignore the
C     contents of these arrays.)
C
C    IOPT(*) CONTENTS
C    ------- --------
C     The option array allows a user to modify some internal variables
C     in the subprogram without recompiling the source code. A central
C     goal of the initial software design was to do a good job for most
C     people. Thus the use of options will be restricted to a select
C     group of users. The processing of the option array proceeds as
C     follows: a pointer, here called LP, is initially set to the value
C     1. At the pointer position the option number is extracted and
C     used for locating other information that allows for options to be
C     changed. The portion of the array IOPT(*) that is used for each
C     option is fixed; the user and the subprogram both know how many
C     locations are needed for each option. The value of LP is updated
C     for each option based on the amount of storage in IOPT(*) that is
C     required. A great deal of error checking is done by the
C     subprogram on the contents of the option array. Nevertheless it
C     is still possible to give the subprogram optional input that is
C     meaningless. For example option 4 uses the locations
C     X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing scaling data.
C     The user must manage the allocation of these locations.
C
C   1
C   -
C     This option allows the user to solve problems with a large number
C     of rows compared to the number of variables. The idea is that the
C     subprogram returns to the user (perhaps many times) and receives
C     new least squares equations from the calling program unit.
C     Eventually the user signals "that's all" and a solution is then
C     computed. The value of MROWS is an output variable when this
C     option is used. Its value is always in the range 0 .le. MROWS
C     .le. NCOLS+1. It is the number of rows after the
C     triangularization of the entire set of equations. If LP is the
C     processing pointer for IOPT(*), the usage for the sequential
C     processing of blocks of equations is
C
C
C        IOPT(LP)=1
C         Move block of equations to W(*,*) starting at
C         the first row of W(*,*).
C        IOPT(LP+3)=# of rows in the block; user defined
C
C     The user now calls SBOCLS( ) in a loop. The value of IOPT(LP+1)
C     directs the user's action. The value of IOPT(LP+2) points to
C     where the subsequent rows are to be placed in W(*,*). Both of
C     these values are first defined in the subprogram. The user
C     changes the value of IOPT(LP+1) (to 2) as a signal that all of
C     the rows have been processed.
C
C
C      .<LOOP
C      . CALL SBOCLS( )
C      . IF(IOPT(LP+1) .EQ. 1) THEN
C      .    IOPT(LP+3)=# OF ROWS IN THE NEW BLOCK; USER DEFINED
C      .    PLACE NEW BLOCK OF IOPT(LP+3) ROWS IN
C      .    W(*,*) STARTING AT ROW MCON + IOPT(LP+2).
C      .
C      .    IF( THIS IS THE LAST BLOCK OF EQUATIONS ) THEN
C      .       IOPT(LP+1)=2
C      .<------CYCLE LOOP
C      .    ELSE IF (IOPT(LP+1) .EQ. 2) THEN
C      <-------EXIT LOOP SOLUTION COMPUTED IF MODE .GE. 0
C      . ELSE
C      . ERROR CONDITION; SHOULD NOT HAPPEN.
C      .<END LOOP
C
C     Use of this option adds 4 to the required length of IOPT(*).
C
C   2
C   -
C     This option is useful for checking the lengths of all arrays used
C     by SBOCLS( ) against their actual requirements for this problem.
C     The idea is simple: the user's program unit passes the declared
C     dimension information of the arrays. These values are compared
C     against the problem-dependent needs within the subprogram. If any
C     of the dimensions are too small an error message is printed and a
C     negative value of MODE is returned, -41 to -47. The printed error
C     message tells how long the dimension should be. If LP is the
C     processing pointer for IOPT(*),
C
C        IOPT(LP)=2
C        IOPT(LP+1)=Row dimension of W(*,*)
C        IOPT(LP+2)=Col. dimension of W(*,*)
C        IOPT(LP+3)=Dimensions of BL(*),BU(*),IND(*)
C        IOPT(LP+4)=Dimension of X(*)
C        IOPT(LP+5)=Dimension of RW(*)
C        IOPT(LP+6)=Dimension of IW(*)
C        IOPT(LP+7)=Dimension of IOPT(*)
C         .
C        CALL SBOCLS( )
C
C     Use of this option adds 8 to the required length of IOPT(*).
C
C   3
C   -
C     This option can change the type of scaling for the data matrix.
C     Nominally each nonzero column of the matrix is scaled so that the
C     magnitude of its largest entry is equal to the value ONE. If LP
C     is the processing pointer for IOPT(*),
C
C        IOPT(LP)=3
C        IOPT(LP+1)=1,2 or 3
C            1= Nominal scaling as noted;
C            2= Each nonzero column scaled to have length ONE;
C            3= Identity scaling; scaling effectively suppressed.
C         .
C        CALL SBOCLS( )
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   4
C   -
C     This options allows the user to provide arbitrary (positive)
C     column scaling for the matrix. If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=4
C        IOPT(LP+1)=IOFF
C        X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1)
C        = Positive scale factors for cols. of E.
C         .
C        CALL SBOCLS( )
C
C     Use of this option adds 2 to the required length of IOPT(*)
C     and NCOLS to the required length of X(*).
C
C   5
C   -
C     This option allows the user to provide an option array to the
C     low-level subprogram SBOLS( ). If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=5
C        IOPT(LP+1)= Position in IOPT(*) where option array
C                    data for SBOLS( ) begins.
C         .
C        CALL SBOCLS( )
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   6
C   -
C     This option allows the user to provide an option array to the
C     low-level subprogram SBOLSM( ). If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=6
C        IOPT(LP+1)= Position in IOPT(*) where option array
C                    data for SBOLSM( ) begins.
C         .
C        CALL SBOCLS( )
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   7
C   -
C     Move the processing pointer (either forward or backward) to the
C     location IOPT(LP+1). The processing pointer moves to locations
C     LP+2 if option number 7 is used with the value -7.  For
C     example to skip over locations 3,...,NCOLS+2,
C
C       IOPT(1)=7
C       IOPT(2)=NCOLS+3
C       (IOPT(I), I=3,...,NCOLS+2 are not defined here.)
C       IOPT(NCOLS+3)=99
C       CALL SBOCLS( )
C
C     CAUTION: Misuse of this option can yield some very hard-to-find
C     bugs. Use it with care. It is intended to be used for passing
C     option arrays to other subprograms.
C
C   8
C   -
C     This option allows the user to suppress the algorithmic feature
C     of SBOCLS( ) that processes the constraint equations C*X = Y and
C     resolves infeasibilities. The steps normally done are to solve
C     C*X - Y = 0 in a least squares sense using the stated bounds on
C     both X and Y. Then the "reachable" vector Y = C*X is computed
C     using the solution X obtained. Finally the stated bounds for Y are
C     enlarged to include C*X. To suppress the feature:
C
C
C       IOPT(LP)=8
C         .
C       CALL SBOCLS( )
C
C     Use of this option adds 1 to the required length of IOPT(*).
C
C   9
C   -
C     This option allows the user to suppress the pretriangularizing
C     step of the least squares matrix that is done within SBOCLS( ).
C     This is primarily a means of enhancing the subprogram efficiency
C     and has little effect on accuracy. To suppress the step, set:
C
C       IOPT(LP)=9
C         .
C       CALL SBOCLS( )
C
C     Use of this option adds 1 to the required length of IOPT(*).
C
C   99
C   --
C     There are no more options to change.
C
C     Only option numbers -99, -9,-8,...,-1, 1,2,...,9, and 99 are
C     permitted. Other values are errors. Options -99,-1,...,-9 mean
C     that the respective options 99,1,...,9 are left at their default
C     values. An example is the option to suppress the preprocessing of
C     constraints:
C
C       IOPT(1)=-8 Option is recognized but not changed
C       IOPT(2)=99
C       CALL SBOCLS( )
C
C    Error Messages for SBOCLS()
C    ----- -------- --- --------
C
C WARNING in...
C SBOCLS(). THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE. THE NUMBER
C OF EFFECTIVE ROWS=(I2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        41
C
C WARNING IN...
C SBOCLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE .GE. NCOLS+
C MCON+1=(I2).
C           IN ABOVE MESSAGE, I1=         2
C           IN ABOVE MESSAGE, I2=         3
C ERROR NUMBER =        42
C
C WARNING IN...
C SBOCLS(). THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1)
C MUST BE .GE. NCOLS+MCON=(I2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        43
C
C WARNING IN...
C SBOCLS(). THE DIMENSION OF X()=(I1) MUST BE
C .GE. THE REQD.LENGTH=(I2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        44
C
C WARNING IN...
C SBOCLS(). THE .
C SBOCLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*NCOLS+2*MCON=(I2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         4
C ERROR NUMBER =        46
C
C WARNING IN...
C SBOCLS(). THE DIMENSION OF IOPT()=(I1) MUST BE .GE. THE REQD.
C LEN.=(I2).
C           IN ABOVE MESSAGE, I1=        16
C           IN ABOVE MESSAGE, I2=        18
C ERROR NUMBER =        47
C
C WARNING IN...
C SBOCLS(). ISCALE OPTION=(I1) MUST BE 1-3.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =        48
C
C WARNING IN...
C SBOCLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED COLUMN SCALING
C MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =        49
C
C WARNING IN...
C SBOCLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE.
C  COMPONENT (I1) NOW = (R1).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, R1=    0.
C ERROR NUMBER =        50
C
C WARNING IN...
C SBOCLS(). THE OPTION NUMBER=(I1) IS NOT DEFINED.
C           IN ABOVE MESSAGE, I1=      1001
C ERROR NUMBER =        51
C
C WARNING IN...
C SBOCLS(). NO. OF ROWS=(I1) MUST BE .GE. 0 .AND. .LE. MDW-MCON=(I2).
C           IN ABOVE MESSAGE, I1=         2
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        52
C
C WARNING IN...
C SBOCLS(). MDW=(I1) MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =        53
C
C WARNING IN...
C SBOCLS(). MCON=(I1) MUST BE NONNEGATIVE.
C           IN ABOVE MESSAGE, I1=        -1
C ERROR NUMBER =        54
C
C WARNING IN...
C SBOCLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =        55
C
C WARNING IN...
C SBOCLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4.
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         0
C ERROR NUMBER =        56
C
C WARNING IN...
C SBOCLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. BU(J)=(R2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, R1=     .1000000000E+01
C           IN ABOVE MESSAGE, R2=    0.
C ERROR NUMBER =        57
C           LINEAR CONSTRAINTS, SNLA REPT. SAND82-1517, AUG. (1982).
C
C***REFERENCES  R. J. Hanson, Linear least squares with bounds and
C                 linear constraints, Report SAND82-1517, Sandia
C                 Laboratories, August 1982.
C***ROUTINES CALLED  R1MACH, SASUM, SBOLS, SCOPY, SDOT, SNRM2, SSCAL,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   821220  DATE WRITTEN
C   870803  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   910819  Added variable M for MOUT+MCON in reference to SBOLS.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SBOCLS
C     REVISED 850604-0900
C     REVISED YYMMDD-HHMM
C
C    PURPOSE
C    -------
C     THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE LEAST SQUARES
C     PROBLEM CONSISTING OF LINEAR CONSTRAINTS
C
C              C*X = Y
C
C     AND LEAST SQUARES EQUATIONS
C
C              E*X = F
C
C     IN THIS FORMULATION THE VECTORS X AND Y ARE BOTH UNKNOWNS.
C     FURTHER, X AND Y MAY BOTH HAVE USER-SPECIFIED BOUNDS ON EACH
C     COMPONENT.  THE USER MUST HAVE DIMENSION STATEMENTS OF THE
C     FORM
C
C     DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON),BU(NCOLS+MCON),
C               X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON)
C
C     INTEGER IND(NCOLS+MCON), IOPT(16+NI), IW(2*(NCOLS+MCON))
C
C     TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN
C     EDITING AT THE CARD 'C++'.
C     CHANGE THIS SUBPROGRAM TO SBOCLS AND THE STRINGS
C     /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, /SRELPR/ TO /DRELPR/,
C     /R1MACH/ TO /D1MACH/, /E0/ TO /D0/, /SCOPY/ TO /DCOPY/,
C     /SSCAL/ TO /DSCAL/, /SASUM/ TO /DASUM/, /SBOLS/ TO /DBOLS/,
C     /REAL            / TO /DOUBLE PRECISION/.
C ++
      REAL             W(MDW,*),BL(*),BU(*),X(*),RW(*)
      REAL             ANORM, CNORM, ONE, RNORM, RNORMC, SRELPR
      REAL             T, T1, T2, SDOT, SNRM2, WT, ZERO
      REAL             SASUM, R1MACH
C     THIS VARIABLE REMAINS TYPED REAL.
      INTEGER IND(*),IOPT(*),IW(*),JOPT(05)
      LOGICAL CHECKL,FILTER,ACCUM,PRETRI
      CHARACTER*8 XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
      SAVE IGO,ACCUM,CHECKL
      DATA IGO/0/
C***FIRST EXECUTABLE STATEMENT  SBOCLS
      NERR = 0
      MODE = 0
      IF (IGO.EQ.0) THEN
C     DO(CHECK VALIDITY OF INPUT DATA)
C     PROCEDURE(CHECK VALIDITY OF INPUT DATA)
C
C     SEE THAT MDW IS .GT.0. GROSS CHECK ONLY.
          IF (MDW.LE.0) THEN
              WRITE (XERN1, '(I8)') MDW
              CALL XERMSG ('SLATEC', 'SBOCLS', 'MDW = ' // XERN1 //
     *           ' MUST BE POSITIVE.', 53, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 260
          ENDIF
C
C     SEE THAT NUMBER OF CONSTRAINTS IS NONNEGATIVE.
          IF (MCON.LT.0) THEN
              WRITE (XERN1, '(I8)') MCON
              CALL XERMSG ('SLATEC', 'SBOCLS', 'MCON = ' // XERN1 //
     *           ' MUST BE NON-NEGATIVE', 54, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 260
          ENDIF
C
C     SEE THAT NUMBER OF UNKNOWNS IS POSITIVE.
          IF (NCOLS.LE.0) THEN
              WRITE (XERN1, '(I8)') NCOLS
              CALL XERMSG ('SLATEC', 'SBOCLS', 'NCOLS = ' // XERN1 //
     *           ' THE NO. OF VARIABLES, MUST BE POSITIVE.', 55, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 260
          ENDIF
C
C     SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED.
          DO 10 J = 1,NCOLS + MCON
              IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN
                  WRITE (XERN1, '(I8)') J
                  WRITE (XERN2, '(I8)') IND(J)
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *              'IND(' // XERN1 // ') = ' // XERN2 //
     *              ' MUST BE 1-4.', 56, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
   10     CONTINUE
C
C     SEE THAT BOUNDS ARE CONSISTENT.
          DO 20 J = 1,NCOLS + MCON
              IF (IND(J).EQ.3) THEN
                  IF (BL(J).GT.BU(J)) THEN
                     WRITE (XERN1, '(I8)') J
                     WRITE (XERN3, '(1PE15.6)') BL(J)
                     WRITE (XERN4, '(1PE15.6)') BU(J)
                     CALL XERMSG ('SLATEC', 'SBOCLS',
     *                  'BOUND BL(' // XERN1 // ') = ' // XERN3 //
     *                  ' IS .GT. BU(' // XERN1 // ') = ' // XERN4,
     *                  57, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 260
                  ENDIF
              ENDIF
   20     CONTINUE
C     END PROCEDURE
C     DO(PROCESS OPTION ARRAY)
C     PROCEDURE(PROCESS OPTION ARRAY)
          ZERO = 0.E0
          ONE = 1.E0
          SRELPR = R1MACH(4)
          CHECKL = .FALSE.
          FILTER = .TRUE.
          LENX = 2* (NCOLS+MCON) + 2
          ISCALE = 1
          IGO = 1
          ACCUM = .FALSE.
          PRETRI = .TRUE.
          LOPT = 0
          MOPT = 0
          LP = 0
          LDS = 0
C     DO FOREVER
   30     CONTINUE
          LP = LP + LDS
          IP = IOPT(LP+1)
          JP = ABS(IP)
C
C     TEST FOR NO MORE OPTIONS TO CHANGE.
          IF (IP.EQ.99) THEN
              IF (LOPT.EQ.0) LOPT = - (LP+2)
              IF (MOPT.EQ.0) MOPT = - (ABS(LOPT)+7)
              IF (LOPT.LT.0) THEN
                  LBOU = ABS(LOPT)
              ELSE
                  LBOU = LOPT - 15
              ENDIF
C
C     SEND COL. SCALING TO SBOLS().
              IOPT(LBOU) = 4
              IOPT(LBOU+1) = 1
C
C     PASS AN OPTION ARRAY FOR SBOLSM().
              IOPT(LBOU+2) = 5
C
C     LOC. OF OPTION ARRAY FOR SBOLSM( ).
              IOPT(LBOU+3) = 8
C
C     SKIP TO START OF USER-GIVEN OPTION ARRAY FOR SBOLS().
              IOPT(LBOU+4) = 6
              IOPT(LBOU+6) = 99
              IF (LOPT.GT.0) THEN
                  IOPT(LBOU+5) = LOPT - LBOU + 1
              ELSE
                  IOPT(LBOU+4) = -IOPT(LBOU+4)
              ENDIF
              IF (MOPT.LT.0) THEN
                  LBOUM = ABS(MOPT)
              ELSE
                  LBOUM = MOPT - 8
              ENDIF
C
C     CHANGE PRETRIANGULARIZATION FACTOR IN SBOLSM().
              IOPT(LBOUM) = 5
              IOPT(LBOUM+1) = NCOLS + MCON + 1
C
C     PASS WEIGHT TO SBOLSM() FOR RANK TEST.
              IOPT(LBOUM+2) = 6
              IOPT(LBOUM+3) = NCOLS + MCON + 2
              IOPT(LBOUM+4) = MCON
C
C     SKIP TO USER-GIVEN OPTION ARRAY FOR SBOLSM( ).
              IOPT(LBOUM+5) = 1
              IOPT(LBOUM+7) = 99
              IF (MOPT.GT.0) THEN
                  IOPT(LBOUM+6) = MOPT - LBOUM + 1
              ELSE
                  IOPT(LBOUM+5) = -IOPT(LBOUM+5)
              ENDIF
C     EXIT FOREVER
              GO TO 50
          ELSE IF (JP.EQ.99) THEN
              LDS = 1
C     CYCLE FOREVER
              GO TO 50
          ELSE IF (JP.EQ.1) THEN
              IF (IP.GT.0) THEN
C
C     SET UP DIRECTION FLAG LOCATION, ROW STACKING POINTER
C     LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS.
                  LOCACC = LP + 2
C
C                  IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION.
C     CONTENTS..   IOPT(LOCACC  )=USER DIRECTION FLAG, 1 OR 2.
C                  IOPT(LOCACC+1)=ROW STACKING POINTER.
C                  IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS.
C     USER ACTION WITH THIS OPTION..
C      (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).)
C      (MOVE BLOCK OF EQUATIONS INTO W(*,*)  STARTING AT FIRST
C       ROW OF W(*,*) BELOW THE ROWS FOR THE CONSTRAINT MATRIX C.
C       SET IOPT(LOCACC+2)=NO. OF LEAST SQUARES EQUATIONS IN BLOCK.
C              LOOP
C              CALL SBOCLS()
C
C                  IF(IOPT(LOCACC) .EQ. 1) THEN
C                      STACK EQUAS. INTO W(*,*), STARTING AT
C                      ROW IOPT(LOCACC+1).
C                       INTO W(*,*).
C                       SET IOPT(LOCACC+2)=NO. OF EQUAS.
C                      IF LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2.
C                  ELSE IF IOPT(LOCACC) .EQ. 2) THEN
C                      (PROCESS IS OVER. EXIT LOOP.)
C                  ELSE
C                      (ERROR CONDITION. SHOULD NOT HAPPEN.)
C                  END IF
C              END LOOP
                  IOPT(LOCACC+1) = MCON + 1
                  ACCUM = .TRUE.
                  IOPT(LOCACC) = IGO
              ENDIF
              LDS = 4
C     CYCLE FOREVER
              GO TO 30
          ELSE IF (JP.EQ.2) THEN
              IF (IP.GT.0) THEN
C
C     GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS.
                  LOCDIM = LP + 2
C
C     LMDW.GE.MCON+MAX(MOUT,NCOLS), IF MCON.GT.0 .AND FILTER
C     LMDW.GE.MCON+MOUT, OTHERWISE
C
C     LNDW.GE.NCOLS+MCON+1
C     LLB .GE.NCOLS+MCON
C     LLX .GE.2*(NCOLS+MCON)+2+EXTRA REQD. IN OPTIONS.
C     LLRW.GE.6*NCOLS+5*MCON
C     LLIW.GE.2*(NCOLS+MCON)
C     LIOP.GE. AMOUNT REQD. FOR OPTION 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.
              ENDIF
              LDS = 8
C     CYCLE FOREVER
              GO TO 30
C
C     OPTION TO MODIFY THE COLUMN SCALING.
          ELSE IF (JP.EQ.3) THEN
              IF (IP.GT.0) THEN
                  ISCALE = IOPT(LP+2)
C
C     SEE THAT ISCALE IS 1 THRU 3.
                  IF (ISCALE.LT.1 .OR. ISCALE.GT.3) THEN
                      WRITE (XERN1, '(I8)') ISCALE
                      CALL XERMSG ('SLATEC', 'SBOCLS',
     *                   'ISCALE OPTION = ' // XERN1 // ' MUST BE 1-3',
     *                   48, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 260
                  ENDIF
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION THE USER HAS PROVIDED SCALING.  THE
C     SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)).
          ELSE IF (JP.EQ.4) THEN
              IF (IP.GT.0) THEN
                  ISCALE = 4
                  IF (IOPT(LP+2).LE.0) THEN
                      WRITE (XERN1, '(I8)') IOPT(LP+2)
                      CALL XERMSG ('SLATEC', 'SBOCLS',
     *                   'OFFSET PAST X(NCOLS) (' // XERN1 //
     *           ') FOR USER-PROVIDED COLUMN SCALING MUST BE POSITIVE.',
     *                   49, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 260
                  ENDIF
                  CALL SCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1)
                  LENX = LENX + NCOLS
                  DO 40 J = 1,NCOLS
                      IF (RW(J).LE.ZERO) THEN
                          WRITE (XERN1, '(I8)') J
                          WRITE (XERN3, '(1PE15.6)') RW(J)
                          CALL XERMSG ('SLATEC', 'SBOCLS',
     *                       'EACH PROVIDED COLUMN SCALE FACTOR ' //
     *                       'MUST BE POSITIVE.$$COMPONENT ' // XERN1 //
     *                       ' NOW = ' // XERN3, 50, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                          GO TO 260
                      ENDIF
   40             CONTINUE
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO SBOLS().
          ELSE IF (JP.EQ.5) THEN
              IF (IP.GT.0) THEN
                  LOPT = IOPT(LP+2)
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO SBOLSM().
          ELSE IF (JP.EQ.6) THEN
              IF (IP.GT.0) THEN
                  MOPT = IOPT(LP+2)
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     THIS OPTION USES THE NEXT LOC OF IOPT(*) AS A
C     POINTER VALUE TO SKIP TO NEXT.
          ELSE IF (JP.EQ.7) THEN
              IF (IP.GT.0) THEN
                  LP = IOPT(LP+2) - 1
                  LDS = 0
              ELSE
                  LDS = 2
              ENDIF
C     CYCLE FOREVER
              GO TO 30
C
C     THIS OPTION AVOIDS THE CONSTRAINT RESOLVING PHASE FOR
C     THE LINEAR CONSTRAINTS C*X=Y.
          ELSE IF (JP.EQ.8) THEN
              FILTER = .NOT. (IP.GT.0)
              LDS = 1
C     CYCLE FOREVER
              GO TO 30
C
C     THIS OPTION SUPPRESSES PRE-TRIANGULARIZATION OF THE LEAST
C     SQUARES EQUATIONS.
          ELSE IF (JP.EQ.9) THEN
              PRETRI = .NOT. (IP.GT.0)
              LDS = 1
C     CYCLE FOREVER
              GO TO 30
C
C     NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION.
          ELSE
              WRITE (XERN1, '(I8)') JP
              CALL XERMSG ('SLATEC', 'SBOCLS', 'OPTION NUMBER = ' //
     *           XERN1 // ' IS NOT DEFINED.', 51, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 260
          ENDIF
C     END FOREVER
C     END PROCEDURE
   50     CONTINUE
          IF (CHECKL) THEN
C     DO(CHECK LENGTHS OF ARRAYS)
C     PROCEDURE(CHECK LENGTHS OF ARRAYS)
C
C     THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE
C     ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE.
           IF(FILTER .AND. .NOT.ACCUM) THEN
                MDWL=MCON+MAX(MROWS,NCOLS)
           ELSE
                MDWL=MCON+NCOLS+1
           ENDIF
              IF (LMDW.LT.MDWL) THEN
                  WRITE (XERN1, '(I8)') LMDW
                  WRITE (XERN2, '(I8)') MDWL
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *               'THE ROW DIMENSION OF W(,) = ' // XERN1 //
     *               ' MUST BE .GE. THE NUMBER OF EFFECTIVE ROWS = ' //
     *               XERN2, 41, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
              IF (LNDW.LT.NCOLS+MCON+1) THEN
                  WRITE (XERN1, '(I8)') LNDW
                  WRITE (XERN2, '(I8)') NCOLS+MCON+1
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *               'THE COLUMN DIMENSION OF W(,) = ' // XERN1 //
     *               ' MUST BE .GE. NCOLS+MCON+1 = ' // XERN2, 42, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
              IF (LLB.LT.NCOLS+MCON) THEN
                  WRITE (XERN1, '(I8)') LLB
                  WRITE (XERN2, '(I8)') NCOLS+MCON
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *           'THE DIMENSIONS OF THE ARRAYS BS(), BU(), AND IND() = '
     *               // XERN1 // ' MUST BE .GE. NCOLS+MCON = ' // XERN2,
     *               43, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
              IF (LLX.LT.LENX) THEN
                  WRITE (XERN1, '(I8)') LLX
                  WRITE (XERN2, '(I8)') LENX
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *              'THE DIMENSION OF X() = ' // XERN1 //
     *              ' MUST BE .GE. THE REQD. LENGTH = ' // XERN2, 44, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
              IF (LLRW.LT.6*NCOLS+5*MCON) THEN
                  WRITE (XERN1, '(I8)') LLRW
                  WRITE (XERN2, '(I8)') 6*NCOLS+5*MCON
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *               'THE DIMENSION OF RW() = ' // XERN1 //
     *               ' MUST BE .GE. 6*NCOLS+5*MCON = ' // XERN2, 45, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
              IF (LLIW.LT.2*NCOLS+2*MCON) THEN
                  WRITE (XERN1, '(I8)') LLIW
                  WRITE (XERN2, '(I8)') 2*NCOLS+2*MCON
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *               'THE DIMENSION OF IW() = ' // XERN1 //
     *               ' MUST BE .GE. 2*NCOLS+2*MCON = ' // XERN2, 46, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
              IF (LIOPT.LT.LP+17) THEN
                  WRITE (XERN1, '(I8)') LIOPT
                  WRITE (XERN2, '(I8)') LP+17
                  CALL XERMSG ('SLATEC', 'SBOCLS',
     *               'THE DIMENSION OF IOPT() = ' // XERN1 //
     *               ' MUST BE .GE. THE REQD. LEN = ' // XERN2, 47, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 260
              ENDIF
C     END PROCEDURE
          ENDIF
      ENDIF
C
C     OPTIONALLY GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES
C     EQUATIONS AND DIRECTIONS FOR PROCESSING THESE EQUATIONS.
C     DO(ACCUMULATE LEAST SQUARES EQUATIONS)
C     PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS)
      IF (ACCUM) THEN
          MROWS = IOPT(LOCACC+1) - 1 - MCON
          INROWS = IOPT(LOCACC+2)
          MNEW = MROWS + INROWS
          IF (MNEW.LT.0 .OR. MNEW+MCON.GT.MDW) THEN
              WRITE (XERN1, '(I8)') MNEW
              WRITE (XERN2, '(I8)') MDW-MCON
              CALL XERMSG ('SLATEC', 'SBOCLS', 'NO. OF ROWS = ' //
     *           XERN1 //  ' MUST BE .GE. 0 .AND. .LE. MDW-MCON = ' //
     *           XERN2, 52, 1)
C    (RETURN TO USER PROGRAM UNIT)
              GO TO 260
          ENDIF
      ENDIF
C
C     USE THE SOFTWARE OF SBOLS( ) FOR THE TRIANGULARIZATION OF THE
C     LEAST SQUARES MATRIX.  THIS MAY INVOLVE A SYSTALTIC INTERCHANGE
C     OF PROCESSING POINTERS BETWEEN THE CALLING AND CALLED (SBOLS())
C     PROGRAM UNITS.
      JOPT(01) = 1
      JOPT(02) = 2
      JOPT(04) = MROWS
      JOPT(05) = 99
      IRW = NCOLS + 1
      IIW = 1
      IF (ACCUM .OR. PRETRI) THEN
          CALL SBOLS(W(MCON+1,1),MDW,MOUT,NCOLS,BL,BU,IND,JOPT,X,RNORM,
     *               MODE,RW(IRW),IW(IIW))
      ELSE
          MOUT = MROWS
      ENDIF
      IF (ACCUM) THEN
          ACCUM = IOPT(LOCACC) .EQ. 1
          IOPT(LOCACC+1) = JOPT(03) + MCON
          MROWS = MIN(NCOLS+1,MNEW)
      ENDIF
C     END PROCEDURE
      IF (ACCUM) RETURN
C     DO(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM)
C     PROCEDURE(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM)
C
C     MOVE RIGHT HAND SIDE OF LEAST SQUARES EQUATIONS.
      CALL SCOPY(MOUT,W(MCON+1,NCOLS+1),1,W(MCON+1,NCOLS+MCON+1),1)
      IF (MCON.GT.0 .AND. FILTER) THEN
C
C     PROJECT THE LINEAR CONSTRAINTS INTO A REACHABLE SET.
          DO 60 I = 1,MCON
              CALL SCOPY(NCOLS,W(I,1),MDW,W(MCON+1,NCOLS+I),1)
   60     CONTINUE
C
C      PLACE (-)IDENTITY MATRIX AFTER CONSTRAINT DATA.
          DO 70 J = NCOLS + 1,NCOLS + MCON + 1
              W(1,J) = ZERO
              CALL SCOPY(MCON,W(1,J),0,W(1,J),1)
   70     CONTINUE
          W(1,NCOLS+1) = -ONE
          CALL SCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1)
C
C     OBTAIN A 'FEASIBLE POINT' FOR THE LINEAR CONSTRAINTS.
          JOPT(01) = 99
          IRW = NCOLS + 1
          IIW = 1
          CALL SBOLS(W,MDW,MCON,NCOLS+MCON,BL,BU,IND,JOPT,X,RNORMC,
     *               MODEC,RW(IRW),IW(IIW))
C
C     ENLARGE THE BOUNDS SET, IF REQUIRED, TO INCLUDE POINTS THAT
C     CAN BE REACHED.
          DO 130 J = NCOLS + 1,NCOLS + MCON
              ICASE = IND(J)
              IF (ICASE.LT.4) THEN
                  T = SDOT(NCOLS,W(MCON+1,J),1,X,1)
              ENDIF
              GO TO (80,90,100,110),ICASE
              GO TO 120
C     CASE 1
   80         BL(J) = MIN(T,BL(J))
              GO TO 120
C     CASE 2
   90         BU(J) = MAX(T,BU(J))
              GO TO 120
C     CASE 3
  100         BL(J) = MIN(T,BL(J))
              BU(J) = MAX(T,BU(J))
              GO TO 120
C     CASE 4
  110         CONTINUE
  120         CONTINUE
  130     CONTINUE
C
C     MOVE CONSTRAINT DATA BACK TO THE ORIGINAL AREA.
          DO 140 J = NCOLS + 1,NCOLS + MCON
              CALL SCOPY(NCOLS,W(MCON+1,J),1,W(J-NCOLS,1),MDW)
  140     CONTINUE
      ENDIF
      IF (MCON.GT.0) THEN
          DO 150 J = NCOLS + 1,NCOLS + MCON
              W(MCON+1,J) = ZERO
              CALL SCOPY(MOUT,W(MCON+1,J),0,W(MCON+1,J),1)
  150     CONTINUE
C
C     PUT IN (-)IDENTITY MATRIX (POSSIBLY) ONCE AGAIN.
          DO 160 J = NCOLS + 1,NCOLS + MCON + 1
              W(1,J) = ZERO
              CALL SCOPY(MCON,W(1,J),0,W(1,J),1)
  160     CONTINUE
          W(1,NCOLS+1) = -ONE
          CALL SCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1)
      ENDIF
C
C     COMPUTE NOMINAL COLUMN SCALING FOR THE UNWEIGHTED MATRIX.
      CNORM = ZERO
      ANORM = ZERO
      DO 170 J = 1,NCOLS
          T1 = SASUM(MCON,W(1,J),1)
          T2 = SASUM(MOUT,W(MCON+1,1),1)
          T = T1 + T2
          IF (T.EQ.ZERO) T = ONE
          CNORM = MAX(CNORM,T1)
          ANORM = MAX(ANORM,T2)
          X(NCOLS+MCON+J) = ONE/T
  170 CONTINUE
      GO TO (180,190,210,220),ISCALE
      GO TO 230
C     CASE 1
  180 CONTINUE
      GO TO 230
C     CASE 2
C
C     SCALE COLS. (BEFORE WEIGHTING) TO HAVE LENGTH ONE.
  190 DO 200 J = 1,NCOLS
          T = SNRM2(MCON+MOUT,W(1,J),1)
          IF (T.EQ.ZERO) T = ONE
          X(NCOLS+MCON+J) = ONE/T
  200 CONTINUE
      GO TO 230
C     CASE 3
C
C     SUPPRESS SCALING (USE UNIT MATRIX).
  210 X(NCOLS+MCON+1) = ONE
      CALL SCOPY(NCOLS,X(NCOLS+MCON+1),0,X(NCOLS+MCON+1),1)
      GO TO 230
C     CASE 4
C
C     THE USER HAS PROVIDED SCALING.
  220 CALL SCOPY(NCOLS,RW,1,X(NCOLS+MCON+1),1)
  230 CONTINUE
      DO 240 J = NCOLS + 1,NCOLS + MCON
          X(NCOLS+MCON+J) = ONE
  240 CONTINUE
C
C     WEIGHT THE LEAST SQUARES EQUATIONS.
      WT = SRELPR
      IF (ANORM.GT.ZERO) WT = WT/ANORM
      IF (CNORM.GT.ZERO) WT = WT*CNORM
      DO 250 I = 1,MOUT
          CALL SSCAL(NCOLS,WT,W(I+MCON,1),MDW)
  250 CONTINUE
      CALL SSCAL(MOUT,WT,W(MCON+1,MCON+NCOLS+1),1)
      LRW = 1
      LIW = 1
C
C     SET THE NEW TRIANGULARIZATION FACTOR.
      X(2* (NCOLS+MCON)+1) = ZERO
C
C     SET THE WEIGHT TO USE IN COMPONENTS .GT. MCON,
C     WHEN MAKING LINEAR INDEPENDENCE TEST.
      X(2* (NCOLS+MCON)+2) = ONE/WT
      M=MOUT+MCON
      CALL SBOLS(W,MDW,M,NCOLS+MCON,BL,BU,IND,IOPT(LBOU),X,
     *           RNORM,MODE,RW(LRW),IW(LIW))
      RNORM = RNORM/WT
C     END PROCEDURE
C     PROCEDURE(RETURN TO USER PROGRAM UNIT)
  260 IF(MODE.GE.0)MODE = -NERR
      IGO = 0
      RETURN
C     END PROGRAM
      END
*DECK SBOLS
      SUBROUTINE SBOLS (W, MDW, MROWS, NCOLS, BL, BU, IND, IOPT, X,
     +   RNORM, MODE, RW, IW)
C***BEGIN PROLOGUE  SBOLS
C***PURPOSE  Solve the problem
C                 E*X = F (in the least  squares  sense)
C            with bounds on selected X values.
C***LIBRARY   SLATEC
C***CATEGORY  K1A2A, G2E, G2H1, G2H2
C***TYPE      SINGLE PRECISION (SBOLS-S, DBOLS-D)
C***KEYWORDS  BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     The user must have dimension statements of the form:
C
C       DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS),
C      * X(NCOLS+NX), RW(5*NCOLS)
C       INTEGER IND(NCOLS), IOPT(1+NI), IW(2*NCOLS)
C
C     (here NX=number of extra locations required for option 4; NX=0
C     for no options; NX=NCOLS if this option is in use. Here NI=number
C     of extra locations required for options 1-6; NI=0 for no
C     options.)
C
C   INPUT
C   -----
C
C    --------------------
C    W(MDW,*),MROWS,NCOLS
C    --------------------
C     The array W(*,*) contains the matrix [E:F] on entry. The matrix
C     [E:F] has MROWS rows and NCOLS+1 columns. This data is placed in
C     the array W(*,*) with E occupying the first NCOLS columns and the
C     right side vector F in column NCOLS+1. The row dimension, MDW, of
C     the array W(*,*) must satisfy the inequality MDW .ge. MROWS.
C     Other values of MDW are errors. The values of MROWS and NCOLS
C     must be positive. Other values are errors. There is an exception
C     to this when using option 1 for accumulation of blocks of
C     equations. In that case MROWS is an OUTPUT variable ONLY, and the
C     matrix data for [E:F] is placed in W(*,*), one block of rows at a
C     time.  MROWS contains the number of rows in the matrix after
C     triangularizing several blocks of equations. This is an OUTPUT
C     parameter ONLY when option 1 is used. See IOPT(*) CONTENTS
C     for details about option 1.
C
C    ------------------
C    BL(*),BU(*),IND(*)
C    ------------------
C     These arrays contain the information about the bounds that the
C     solution values are to satisfy. The value of IND(J) tells the
C     type of bound and BL(J) and BU(J) give the explicit values for
C     the respective upper and lower bounds.
C
C    1.    For IND(J)=1, require X(J) .ge. BL(J).
C          (the value of BU(J) is not used.)
C    2.    For IND(J)=2, require X(J) .le. BU(J).
C          (the value of BL(J) is not used.)
C    3.    For IND(J)=3, require X(J) .ge. BL(J) and
C                                X(J) .le. BU(J).
C    4.    For IND(J)=4, no bounds on X(J) are required.
C          (the values of BL(J) and BU(J) are not used.)
C
C     Values other than 1,2,3 or 4 for IND(J) are errors. In the case
C     IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J)
C     is an error.
C
C    -------
C    IOPT(*)
C    -------
C     This is the array where the user can specify nonstandard options
C     for SBOLSM( ). Most of the time this feature can be ignored by
C     setting the input value IOPT(1)=99. Occasionally users may have
C     needs that require use of the following subprogram options. For
C     details about how to use the options see below: IOPT(*) CONTENTS.
C
C     Option Number   Brief Statement of Purpose
C     ------ ------   ----- --------- -- -------
C           1         Return to user for accumulation of blocks
C                     of least squares equations.
C           2         Check lengths of all arrays used in the
C                     subprogram.
C           3         Standard scaling of the data matrix, E.
C           4         User provides column scaling for matrix E.
C           5         Provide option array to the low-level
C                     subprogram SBOLSM( ).
C           6         Move the IOPT(*) processing pointer.
C          99         No more options to change.
C
C    ----
C    X(*)
C    ----
C     This array is used to pass data associated with option 4. Ignore
C     this parameter if this option is not used. Otherwise see below:
C     IOPT(*) CONTENTS.
C
C    OUTPUT
C    ------
C
C    ----------
C    X(*),RNORM
C    ----------
C     The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for
C     the constrained least squares problem. The value RNORM is the
C     minimum residual vector length.
C
C    ----
C    MODE
C    ----
C     The sign of MODE determines whether the subprogram has completed
C     normally, or encountered an error condition or abnormal status. A
C     value of MODE .ge. 0 signifies that the subprogram has completed
C     normally. The value of MODE (.GE. 0) is the number of variables
C     in an active status: not at a bound nor at the value ZERO, for
C     the case of free variables. A negative value of MODE will be one
C     of the cases -37,-36,...,-22, or -17,...,-2. Values .lt. -1
C     correspond to an abnormal completion of the subprogram. To
C     understand the abnormal completion codes see below: ERROR
C     MESSAGES for SBOLS( ). AN approximate solution will be returned
C     to the user only when max. iterations is reached, MODE=-22.
C     Values for MODE=-37,...,-22 come from the low-level subprogram
C     SBOLSM(). See the section ERROR MESSAGES for SBOLSM() in the
C     documentation for SBOLSM().
C
C    -----------
C    RW(*),IW(*)
C    -----------
C     These are working arrays with 5*NCOLS and 2*NCOLS entries.
C     (normally the user can ignore the contents of these arrays,
C     but they must be dimensioned properly.)
C
C    IOPT(*) CONTENTS
C    ------- --------
C     The option array allows a user to modify internal variables in
C     the subprogram without recompiling the source code. A central
C     goal of the initial software design was to do a good job for most
C     people. Thus the use of options will be restricted to a select
C     group of users. The processing of the option array proceeds as
C     follows: a pointer, here called LP, is initially set to the value
C     1. This value is updated as each option is processed. At the
C     pointer position the option number is extracted and used for
C     locating other information that allows for options to be changed.
C     The portion of the array IOPT(*) that is used for each option is
C     fixed; the user and the subprogram both know how many locations
C     are needed for each option. A great deal of error checking is
C     done by the subprogram on the contents of the option array.
C     Nevertheless it is still possible to give the subprogram optional
C     input that is meaningless. For example option 4 uses the
C     locations X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing
C     scaling data. The user must manage the allocation of these
C     locations.
C
C   1
C   -
C     This option allows the user to solve problems with a large number
C     of rows compared to the number of variables. The idea is that the
C     subprogram returns to the user (perhaps many times) and receives
C     new least squares equations from the calling program unit.
C     Eventually the user signals "that's all" and then computes the
C     solution with one final call to subprogram SBOLS( ). The value of
C     MROWS is an OUTPUT variable when this option is used. Its value
C     is always in the range 0 .le. MROWS .le. NCOLS+1. It is equal to
C     the number of rows after the triangularization of the entire set
C     of equations. If LP is the processing pointer for IOPT(*), the
C     usage for the sequential processing of blocks of equations is
C
C        IOPT(LP)=1
C        Move block of equations to W(*,*) starting at
C        the first row of W(*,*).
C        IOPT(LP+3)=# of rows in the block; user defined
C
C     The user now calls SBOLS( ) in a loop. The value of IOPT(LP+1)
C     directs the user's action. The value of IOPT(LP+2) points to
C     where the subsequent rows are to be placed in W(*,*).
C
C      .<LOOP
C      . CALL SBOLS()
C      . IF(IOPT(LP+1) .EQ. 1) THEN
C      .    IOPT(LP+3)=# OF ROWS IN THE NEW BLOCK; USER DEFINED
C      .    PLACE NEW BLOCK OF IOPT(LP+3) ROWS IN
C      .    W(*,*) STARTING AT ROW IOPT(LP+2).
C      .
C      .    IF( THIS IS THE LAST BLOCK OF EQUATIONS ) THEN
C      .       IOPT(LP+1)=2
C      .<------CYCLE LOOP
C      .    ELSE IF (IOPT(LP+1) .EQ. 2) THEN
C      <-------EXIT LOOP SOLUTION COMPUTED IF MODE .GE. 0
C      . ELSE
C      . ERROR CONDITION; SHOULD NOT HAPPEN.
C      .<END LOOP
C
C     Use of this option adds 4 to the required length of IOPT(*).
C
C
C   2
C   -
C     This option is useful for checking the lengths of all arrays used
C     by SBOLS() against their actual requirements for this problem.
C     The idea is simple: the user's program unit passes the declared
C     dimension information of the arrays. These values are compared
C     against the problem-dependent needs within the subprogram. If any
C     of the dimensions are too small an error message is printed and a
C     negative value of MODE is returned, -11 to -17. The printed error
C     message tells how long the dimension should be. If LP is the
C     processing pointer for IOPT(*),
C
C        IOPT(LP)=2
C        IOPT(LP+1)=Row dimension of W(*,*)
C        IOPT(LP+2)=Col. dimension of W(*,*)
C        IOPT(LP+3)=Dimensions of BL(*),BU(*),IND(*)
C        IOPT(LP+4)=Dimension of X(*)
C        IOPT(LP+5)=Dimension of RW(*)
C        IOPT(LP+6)=Dimension of IW(*)
C        IOPT(LP+7)=Dimension of IOPT(*)
C         .
C        CALL SBOLS()
C
C     Use of this option adds 8 to the required length of IOPT(*).
C
C   3
C   -
C     This option changes the type of scaling for the data matrix E.
C     Nominally each nonzero column of E is scaled so that the
C     magnitude of its largest entry is equal to the value ONE. If LP
C     is the processing pointer for IOPT(*),
C
C        IOPT(LP)=3
C        IOPT(LP+1)=1,2 or 3
C            1= Nominal scaling as noted;
C            2= Each nonzero column scaled to have length ONE;
C            3= Identity scaling; scaling effectively suppressed.
C         .
C        CALL SBOLS()
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   4
C   -
C     This option allows the user to provide arbitrary (positive)
C     column scaling for the matrix E. If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=4
C        IOPT(LP+1)=IOFF
C        X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1)
C        = Positive scale factors for cols. of E.
C         .
C        CALL SBOLS()
C
C     Use of this option adds 2 to the required length of IOPT(*) and
C     NCOLS to the required length of X(*).
C
C   5
C   -
C     This option allows the user to provide an option array to the
C     low-level subprogram SBOLSM(). If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=5
C        IOPT(LP+1)= Position in IOPT(*) where option array
C                    data for SBOLSM() begins.
C         .
C        CALL SBOLS()
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   6
C   -
C     Move the processing pointer (either forward or backward) to the
C     location IOPT(LP+1). The processing point is moved to entry
C     LP+2 of IOPT(*) if the option is left with -6 in IOPT(LP).  For
C     example to skip over locations 3,...,NCOLS+2 of IOPT(*),
C
C       IOPT(1)=6
C       IOPT(2)=NCOLS+3
C       (IOPT(I), I=3,...,NCOLS+2 are not defined here.)
C       IOPT(NCOLS+3)=99
C       CALL SBOLS()
C
C     CAUTION: Misuse of this option can yield some very hard
C     -to-find bugs.  Use it with care.
C
C   99
C   --
C     There are no more options to change.
C
C     Only option numbers -99, -6,-5,...,-1, 1,2,...,6, and 99 are
C     permitted. Other values are errors. Options -99,-1,...,-6 mean
C     that the respective options 99,1,...,6 are left at their default
C     values. An example is the option to modify the (rank) tolerance:
C
C       IOPT(1)=-3 Option is recognized but not changed
C       IOPT(2)=2  Scale nonzero cols. to have length ONE
C       IOPT(3)=99
C
C    ERROR MESSAGES for SBOLS()
C    ----- -------- --- -------
C
C WARNING IN...
C SBOLS(). MDW=(I1) MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         2
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         3
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4.
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         0
C ERROR NUMBER =         4
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. BU(J)=(R2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, R1=    0.
C           IN ABOVE MESSAGE, R2=    ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         6
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). ISCALE OPTION=(I1) MUST BE 1-3.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         7
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED  COLUMN SCALING
C MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         8
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE.
C COMPONENT (I1) NOW = (R1).
C           IN ABOVE MESSAGE, I1=        ND. .LE. MDW=(I2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         0
C ERROR NUMBER =        10
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS().THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE.THE NUMBER OF ROWS=
C (I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        11
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE .GE. NCOLS+1=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        12
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS().THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) MUST BE
C .GE. NCOLS=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        13
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). THE DIMENSION OF X()=(I1) MUST BE .GE. THE REQD. LENGTH=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        14
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS(). THE DIMENSION OF RW()=(I1) MUST BE .GE. 5*NCOLS=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         3
C ERROR NUMBER =        15
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*NCOLS=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        16
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C SBOLS() THE DIMENSION OF IOPT()=(I1) MUST BE .GE. THE REQD. LEN.=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        17
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C***REFERENCES  R. J. Hanson, Linear least squares with bounds and
C                 linear constraints, Report SAND82-1517, Sandia
C                 Laboratories, August 1982.
C***ROUTINES CALLED  ISAMAX, SBOLSM, SCOPY, SNRM2, SROT, SROTG, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   821220  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SBOLS
C
C     SOLVE LINEAR LEAST SQUARES SYSTEM WITH BOUNDS ON
C     SELECTED VARIABLES.
C     REVISED 850329-1400
C     REVISED YYMMDD-HHMM
C     TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN
C     EDITING AT THE CARD 'C++'.
C     CHANGE THIS SUBPROGRAM NAME TO DBOLS AND THE STRINGS
C     /SCOPY/ TO /DCOPY/, /SBOL/ TO /DBOL/,
C     /SNRM2/ TO /DNRM2/, /ISAMAX/ TO /IDAMAX/,
C     /SROTG/ TO /DROTG/, /SROT/ TO /DROT/, /E0/ TO /D0/,
C     /REAL            / TO /DOUBLE PRECISION/.
C ++
      REAL             W(MDW,*),BL(*),BU(*),X(*),RW(*)
      REAL             SC, SS, ONE, SNRM2, RNORM, ZERO
C
C     THIS VARIABLE SHOULD REMAIN TYPE REAL.
      INTEGER IND(*),IOPT(*),IW(*)
      LOGICAL CHECKL
      CHARACTER*8 XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
      SAVE IGO,LOCACC,LOPT,ISCALE
      DATA IGO/0/
C***FIRST EXECUTABLE STATEMENT  SBOLS
      NERR = 0
      MODE = 0
      IF (IGO.EQ.0) THEN
C     DO(CHECK VALIDITY OF INPUT DATA)
C     PROCEDURE(CHECK VALIDITY OF INPUT DATA)
C
C     SEE THAT MDW IS .GT.0. GROSS CHECK ONLY.
          IF (MDW.LE.0) THEN
              WRITE (XERN1, '(I8)') MDW
              CALL XERMSG ('SLATEC', 'SBOLS', 'MDW = ' // XERN1 //
     *           ' MUST BE POSITIVE.', 2, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 190
          ENDIF
C
C     SEE THAT NUMBER OF UNKNOWNS IS POSITIVE.
          IF (NCOLS.LE.0) THEN
              WRITE (XERN1, '(I8)') NCOLS
              CALL XERMSG ('SLATEC', 'SBOLS', 'NCOLS = ' // XERN1 //
     *           ' THE NO. OF VARIABLES MUST BE POSITIVE.', 3, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 190
          ENDIF
C
C     SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED.
          DO 10 J = 1,NCOLS
              IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN
                  WRITE (XERN1, '(I8)') J
                  WRITE (XERN2, '(I8)') IND(J)
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *               'IND(' // XERN1 // ') = ' // XERN2 //
     *               ' MUST BE 1-4.', 4, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
   10     CONTINUE
C
C     SEE THAT BOUNDS ARE CONSISTENT.
          DO 20 J = 1,NCOLS
              IF (IND(J).EQ.3) THEN
                  IF (BL(J).GT.BU(J)) THEN
                      WRITE (XERN1, '(I8)') J
                      WRITE (XERN3, '(1PE15.6)') BL(J)
                      WRITE (XERN4, '(1PE15.6)') BU(J)
                      CALL XERMSG ('SLATEC', 'SBOLS',
     *                   'BOUND BL(' // XERN1 // ') = ' // XERN3 //
     *                   ' IS .GT. BU(' // XERN1 // ') = ' // XERN4,
     *                   5, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 190
                  ENDIF
              ENDIF
   20     CONTINUE
C     END PROCEDURE
C     DO(PROCESS OPTION ARRAY)
C     PROCEDURE(PROCESS OPTION ARRAY)
          ZERO = 0.E0
          ONE = 1.E0
          CHECKL = .FALSE.
          LENX = NCOLS
          ISCALE = 1
          IGO = 2
          LOPT = 0
          LP = 0
          LDS = 0
   30     CONTINUE
          LP = LP + LDS
          IP = IOPT(LP+1)
          JP = ABS(IP)
C
C     TEST FOR NO MORE OPTIONS.
          IF (IP.EQ.99) THEN
              IF (LOPT.EQ.0) LOPT = LP + 1
              GO TO 50
          ELSE IF (JP.EQ.99) THEN
              LDS = 1
              GO TO 30
          ELSE IF (JP.EQ.1) THEN
              IF (IP.GT.0) THEN
C
C     SET UP DIRECTION FLAG, ROW STACKING POINTER
C     LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS.
                  LOCACC = LP + 2
C
C                  IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION.
C     CONTENTS..   IOPT(LOCACC  )=USER DIRECTION FLAG, 1 OR 2.
C                  IOPT(LOCACC+1)=ROW STACKING POINTER.
C                  IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS.
C     USER ACTION WITH THIS OPTION..
C      (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).
C      MUST ALSO START PROCESS WITH IOPT(LOCACC)=1.)
C      (MOVE BLOCK OF EQUATIONS INTO W(*,*)  STARTING AT FIRST
C       ROW OF W(*,*).  SET IOPT(LOCACC+2)=NO. OF ROWS IN BLOCK.)
C              LOOP
C              CALL SBOLS()
C
C                  IF(IOPT(LOCACC) .EQ. 1) THEN
C                      STACK EQUAS., STARTING AT ROW IOPT(LOCACC+1),
C                       INTO W(*,*).
C                       SET IOPT(LOCACC+2)=NO. OF EQUAS.
C                      IF LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2.
C                  ELSE IF IOPT(LOCACC) .EQ. 2) THEN
C                      (PROCESS IS OVER. EXIT LOOP.)
C                  ELSE
C                      (ERROR CONDITION. SHOULD NOT HAPPEN.)
C                  END IF
C              END LOOP
C              SET IOPT(LOCACC-1)=-OPTION NUMBER FOR SEQ. ACCUMULATION.
C              CALL SBOLS( )
                  IOPT(LOCACC+1) = 1
                  IGO = 1
              ENDIF
              LDS = 4
              GO TO 30
          ELSE IF (JP.EQ.2) THEN
              IF (IP.GT.0) THEN
C
C     GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS.
                  LOCDIM = LP + 2
C
C     LMDW.GE.MROWS
C     LNDW.GE.NCOLS+1
C     LLB .GE.NCOLS
C     LLX .GE.NCOLS+EXTRA REQD. IN OPTIONS.
C     LLRW.GE.5*NCOLS
C     LLIW.GE.2*NCOLS
C     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.
              ENDIF
              LDS = 8
              GO TO 30
C
C     OPTION TO MODIFY THE COLUMN SCALING.
          ELSE IF (JP.EQ.3) THEN
              IF (IP.GT.0) THEN
                  ISCALE = IOPT(LP+2)
C
C     SEE THAT ISCALE IS 1 THRU 3.
                  IF (ISCALE.LT.1 .OR. ISCALE.GT.3) THEN
                      WRITE (XERN1, '(I8)') ISCALE
                      CALL XERMSG ('SLATEC', 'SBOLS', 'ISCALE OPTION = '
     *                   // XERN1 // ' MUST BE 1-3', 7, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 190
                  ENDIF
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION THE USER HAS PROVIDED SCALING.  THE
C     SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)).
          ELSE IF (JP.EQ.4) THEN
              IF (IP.GT.0) THEN
                  ISCALE = 4
                  IF (IOPT(LP+2).LE.0) THEN
                      WRITE (XERN1, '(I8)') IOPT(LP+2)
                      CALL XERMSG ('SLATEC', 'SBOLS',
     *                   'OFFSET PAST X(NCOLS) (' // XERN1 //
     *           ') FOR USER-PROVIDED COLUMN SCALING MUST BE POSITIVE.',
     *                   8, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 190
                  ENDIF
                  CALL SCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1)
                  LENX = LENX + NCOLS
                  DO 40 J = 1,NCOLS
                      IF (RW(J).LE.ZERO) THEN
                          WRITE (XERN1, '(I8)') J
                          WRITE (XERN3, '(1PE15.6)') RW(J)
                          CALL XERMSG ('SLATEC', 'SBOLS',
     *                       'EACH PROVIDED COLUMN SCALE FACTOR ' //
     *                       'MUST BE POSITIVE.$$COMPONENT ' // XERN1 //
     *                       ' NOW = ' // XERN3, 9, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                          GO TO 190
                      ENDIF
   40             CONTINUE
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO SBOLSM().
          ELSE IF (JP.EQ.5) THEN
              IF (IP.GT.0) THEN
                  LOPT = IOPT(LP+2)
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     THIS OPTION USES THE NEXT LOC OF IOPT(*) AS AN
C     INCREMENT TO SKIP.
          ELSE IF (JP.EQ.6) THEN
              IF (IP.GT.0) THEN
                  LP = IOPT(LP+2) - 1
                  LDS = 0
              ELSE
                  LDS = 2
              ENDIF
C     CYCLE FOREVER
              GO TO 30
C
C     NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION.
          ELSE
              WRITE (XERN1, '(I8)') JP
              CALL XERMSG ('SLATEC', 'SBOLS', 'THE OPTION NUMBER = ' //
     *           XERN1 // ' IS NOT DEFINED.', 6, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 190
          ENDIF
   50     CONTINUE
C     END PROCEDURE
          IF (CHECKL) THEN
C     DO(CHECK LENGTHS OF ARRAYS)
C     PROCEDURE(CHECK LENGTHS OF ARRAYS)
C
C     THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE
C     ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE.
              IF (LMDW.LT.MROWS) THEN
                  WRITE (XERN1, '(I8)') LMDW
                  WRITE (XERN2, '(I8)') MROWS
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *               'THE ROW DIMENSION OF W(,) = ' // XERN1 //
     *               ' MUST BE .GE. THE NUMBER OF ROWS = ' // XERN2,
     *               11, 1)
                  GO TO 190
              ENDIF
              IF (LNDW.LT.NCOLS+1) THEN
                  WRITE (XERN1, '(I8)') LNDW
                  WRITE (XERN2, '(I8)') NCOLS+1
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *               'THE COLUMN DIMENSION OF W(,) = ' // XERN1 //
     *               ' MUST BE .GE. NCOLS+1 = ' // XERN2, 12, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLB.LT.NCOLS) THEN
                  WRITE (XERN1, '(I8)') LLB
                  WRITE (XERN2, '(I8)') NCOLS
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *           'THE DIMENSIONS OF THE ARRAYS BL(), BU(), AND IND() = '
     *               // XERN1 // ' MUST BE .GE. NCOLS = ' // XERN2,
     *               13, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLX.LT.LENX) THEN
                  WRITE (XERN1, '(I8)') LLX
                  WRITE (XERN2, '(I8)') LENX
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *              'THE DIMENSION OF X() = ' // XERN1 //
     *              ' MUST BE .GE. THE REQUIRED LENGTH = ' // XERN2,
     *              14, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLRW.LT.5*NCOLS) THEN
                  WRITE (XERN1, '(I8)') LLRW
                  WRITE (XERN2, '(I8)') 5*NCOLS
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *               'THE DIMENSION OF RW() = ' // XERN1 //
     *               ' MUST BE .GE. 5*NCOLS = ' // XERN2, 15, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLIW.LT.2*NCOLS) THEN
                  WRITE (XERN1, '(I8)') LLIW
                  WRITE (XERN2, '(I8)') 2*NCOLS
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *               'THE DIMENSION OF IW() = ' // XERN1 //
     *               ' MUST BE .GE. 2*NCOLS = ' // XERN2, 16, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LIOPT.LT.LP+1) THEN
                  WRITE (XERN1, '(I8)') LIOPT
                  WRITE (XERN2, '(I8)') LP+1
                  CALL XERMSG ('SLATEC', 'SBOLS',
     *               'THE DIMENSION OF IOPT() = ' // XERN1 //
     *               ' MUST BE .GE. THE REQD. LEN = ' // XERN2, 17, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
C     END PROCEDURE
          ENDIF
      ENDIF
      GO TO (60,90),IGO
      GO TO 180
C
C     GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES
C     EQUATIONS AND DIRECTIONS TO QUIT PROCESSING.
C     CASE 1
   60 CONTINUE
C     DO(ACCUMULATE LEAST SQUARES EQUATIONS)
C     PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS)
      MROWS = IOPT(LOCACC+1) - 1
      INROWS = IOPT(LOCACC+2)
      MNEW = MROWS + INROWS
      IF (MNEW.LT.0 .OR. MNEW.GT.MDW) THEN
          WRITE (XERN1, '(I8)') MNEW
          WRITE (XERN2, '(I8)') MDW
          CALL XERMSG ('SLATEC', 'SBOLS', 'NO. OF ROWS = ' // XERN1 //
     *       ' MUST BE .GE. 0 .AND. .LE. MDW = ' // XERN2, 10, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
          GO TO 190
      ENDIF
      DO 80 J = 1,MIN(NCOLS+1,MNEW)
          DO 70 I = MNEW,MAX(MROWS,J) + 1,-1
              IBIG = ISAMAX(I-J,W(J,J),1) + J - 1
C
C     PIVOT FOR INCREASED STABILITY.
              CALL SROTG(W(IBIG,J),W(I,J),SC,SS)
              CALL SROT(NCOLS+1-J,W(IBIG,J+1),MDW,W(I,J+1),MDW,SC,SS)
              W(I,J) = ZERO
   70     CONTINUE
   80 CONTINUE
      MROWS = MIN(NCOLS+1,MNEW)
      IOPT(LOCACC+1) = MROWS + 1
      IGO = IOPT(LOCACC)
C     END PROCEDURE
      IF (IGO.EQ.2) THEN
          IGO = 0
      ENDIF
      GO TO 180
C     CASE 2
   90 CONTINUE
C     DO(INITIALIZE VARIABLES AND DATA VALUES)
C     PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES)
      DO 150 J = 1,NCOLS
          GO TO (100,110,120,130),ISCALE
          GO TO 140
  100     CONTINUE
C     CASE 1
C
C     THIS IS THE NOMINAL SCALING. EACH NONZERO
C     COL. HAS MAX. NORM EQUAL TO ONE.
          IBIG = ISAMAX(MROWS,W(1,J),1)
          RW(J) = ABS(W(IBIG,J))
          IF (RW(J).EQ.ZERO) THEN
              RW(J) = ONE
          ELSE
              RW(J) = ONE/RW(J)
          ENDIF
          GO TO 140
  110     CONTINUE
C     CASE 2
C
C     THIS CHOICE OF SCALING MAKES EACH NONZERO COLUMN
C     HAVE EUCLIDEAN LENGTH EQUAL TO ONE.
          RW(J) = SNRM2(MROWS,W(1,J),1)
          IF (RW(J).EQ.ZERO) THEN
              RW(J) = ONE
          ELSE
              RW(J) = ONE/RW(J)
          ENDIF
          GO TO 140
  120     CONTINUE
C     CASE 3
C
C     THIS CASE EFFECTIVELY SUPPRESSES SCALING BY SETTING
C     THE SCALING MATRIX TO THE IDENTITY MATRIX.
          RW(1) = ONE
          CALL SCOPY(NCOLS,RW,0,RW,1)
          GO TO 160
  130     CONTINUE
C     CASE 4
          GO TO 160
  140     CONTINUE
  150 CONTINUE
  160 CONTINUE
C     END PROCEDURE
C     DO(SOLVE BOUNDED LEAST SQUARES PROBLEM)
C     PROCEDURE(SOLVE BOUNDED LEAST SQUARES PROBLEM)
C
C     INITIALIZE IBASIS(*), J=1,NCOLS, AND IBB(*), J=1,NCOLS,
C     TO =J,AND =1, FOR USE IN SBOLSM( ).
      DO 170 J = 1,NCOLS
          IW(J) = J
          IW(J+NCOLS) = 1
          RW(3*NCOLS+J) = BL(J)
          RW(4*NCOLS+J) = BU(J)
  170 CONTINUE
      CALL SBOLSM(W,MDW,MROWS,NCOLS,RW(3*NCOLS+1),RW(4*NCOLS+1),IND,
     .            IOPT(LOPT),X,RNORM,MODE,RW(NCOLS+1),RW(2*NCOLS+1),RW,
     .            IW,IW(NCOLS+1))
C     END PROCEDURE
      IGO = 0
  180 CONTINUE
      RETURN
C     PROCEDURE(RETURN TO USER PROGRAM UNIT)
  190 IF(MODE.GE.0)MODE = -NERR
      IGO = 0
      RETURN
C     END PROCEDURE
      END
*DECK SBOLSM
      SUBROUTINE SBOLSM (W, MDW, MINPUT, NCOLS, BL, BU, IND, IOPT, X,
     +   RNORM, MODE, RW, WW, SCL, IBASIS, IBB)
C***BEGIN PROLOGUE  SBOLSM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SBOCLS and SBOLS
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SBOLSM-S, DBOLSM-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C          Solve E*X = F (least squares sense) with bounds on
C            selected X values.
C     The user must have DIMENSION statements of the form:
C
C       DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS),
C      * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS)
C       INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS)
C
C     (Here NX=number of extra locations required for options 1,...,7;
C     NX=0 for no options; here NI=number of extra locations possibly
C     required for options 1-7; NI=0 for no options; NI=14 if all the
C     options are simultaneously in use.)
C
C    INPUT
C    -----
C
C    --------------------
C    W(MDW,*),MINPUT,NCOLS
C    --------------------
C     The array W(*,*) contains the matrix [E:F] on entry. The matrix
C     [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in
C     the array W(*,*) with E occupying the first NCOLS columns and the
C     right side vector F in column NCOLS+1. The row dimension, MDW, of
C     the array W(*,*) must satisfy the inequality MDW .ge. MINPUT.
C     Other values of MDW are errors. The values of MINPUT and NCOLS
C     must be positive. Other values are errors.
C
C    ------------------
C    BL(*),BU(*),IND(*)
C    ------------------
C     These arrays contain the information about the bounds that the
C     solution values are to satisfy. The value of IND(J) tells the
C     type of bound and BL(J) and BU(J) give the explicit values for
C     the respective upper and lower bounds.
C
C    1.    For IND(J)=1, require X(J) .ge. BL(J).
C    2.    For IND(J)=2, require X(J) .le. BU(J).
C    3.    For IND(J)=3, require X(J) .ge. BL(J) and
C                                X(J) .le. BU(J).
C    4.    For IND(J)=4, no bounds on X(J) are required.
C     The values of BL(*),BL(*) are modified by the subprogram. Values
C     other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3
C     (upper and lower bounds) the condition BL(J) .gt. BU(J) is an
C     error.
C
C    -------
C    IOPT(*)
C    -------
C     This is the array where the user can specify nonstandard options
C     for SBOLSM. Most of the time this feature can be ignored by
C     setting the input value IOPT(1)=99. Occasionally users may have
C     needs that require use of the following subprogram options. For
C     details about how to use the options see below: IOPT(*) CONTENTS.
C
C     Option Number   Brief Statement of Purpose
C     ----- ------   ----- --------- -- -------
C           1         Move the IOPT(*) processing pointer.
C           2         Change rank determination tolerance.
C           3         Change blow-up factor that determines the
C                     size of variables being dropped from active
C                     status.
C           4         Reset the maximum number of iterations to use
C                     in solving the problem.
C           5         The data matrix is triangularized before the
C                     problem is solved whenever (NCOLS/MINPUT) .lt.
C                     FAC. Change the value of FAC.
C           6         Redefine the weighting matrix used for
C                     linear independence checking.
C           7         Debug output is desired.
C          99         No more options to change.
C
C    ----
C    X(*)
C    ----
C     This array is used to pass data associated with options 1,2,3 and
C     5. Ignore this input parameter if none of these options are used.
C     Otherwise see below: IOPT(*) CONTENTS.
C
C    ----------------
C    IBASIS(*),IBB(*)
C    ----------------
C     These arrays must be initialized by the user. The values
C         IBASIS(J)=J, J=1,...,NCOLS
C         IBB(J)   =1, J=1,...,NCOLS
C     are appropriate except when using nonstandard features.
C
C    ------
C    SCL(*)
C    ------
C     This is the array of scaling factors to use on the columns of the
C     matrix E. These values must be defined by the user. To suppress
C     any column scaling set SCL(J)=1.0, J=1,...,NCOLS.
C
C    OUTPUT
C    ------
C
C    ----------
C    X(*),RNORM
C    ----------
C     The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22)
C     for the constrained least squares problem. The value RNORM is the
C     minimum residual vector length.
C
C    ----
C    MODE
C    ----
C     The sign of mode determines whether the subprogram has completed
C     normally, or encountered an error condition or abnormal status.
C     A value of MODE .ge. 0 signifies that the subprogram has completed
C     normally. The value of MODE (.ge. 0) is the number of variables
C     in an active status: not at a bound nor at the value ZERO, for
C     the case of free variables. A negative value of MODE will be one
C     of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond
C     to an abnormal completion of the subprogram. To understand the
C     abnormal completion codes see below: ERROR MESSAGES for SBOLSM
C     An approximate solution will be returned to the user only when
C     maximum iterations is reached, MODE=-22.
C
C    -----------
C    RW(*),WW(*)
C    -----------
C     These are working arrays each with NCOLS entries. The array RW(*)
C     contains the working (scaled, nonactive) solution values. The
C     array WW(*) contains the working (scaled, active) gradient vector
C     values.
C
C    ----------------
C    IBASIS(*),IBB(*)
C    ----------------
C     These arrays contain information about the status of the solution
C     when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the
C     nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are
C     the active variables. The value (IBB(J)-1) is the number of times
C     variable J was reflected from its upper bound. (Normally the user
C     can ignore these parameters.)
C
C    IOPT(*) CONTENTS
C    ------- --------
C     The option array allows a user to modify internal variables in
C     the subprogram without recompiling the source code. A central
C     goal of the initial software design was to do a good job for most
C     people. Thus the use of options will be restricted to a select
C     group of users. The processing of the option array proceeds as
C     follows: a pointer, here called LP, is initially set to the value
C     1. The value is updated as the options are processed.  At the
C     pointer position the option number is extracted and used for
C     locating other information that allows for options to be changed.
C     The portion of the array IOPT(*) that is used for each option is
C     fixed; the user and the subprogram both know how many locations
C     are needed for each option. A great deal of error checking is
C     done by the subprogram on the contents of the option array.
C     Nevertheless it is still possible to give the subprogram optional
C     input that is meaningless. For example, some of the options use
C     the location X(NCOLS+IOFF) for passing data. The user must manage
C     the allocation of these locations when more than one piece of
C     option data is being passed to the subprogram.
C
C   1
C   -
C     Move the processing pointer (either forward or backward) to the
C     location IOPT(LP+1). The processing pointer is moved to location
C     LP+2 of IOPT(*) in case IOPT(LP)=-1.  For example to skip over
C     locations 3,...,NCOLS+2 of IOPT(*),
C
C       IOPT(1)=1
C       IOPT(2)=NCOLS+3
C       (IOPT(I), I=3,...,NCOLS+2 are not defined here.)
C       IOPT(NCOLS+3)=99
C       CALL SBOLSM
C
C     CAUTION: Misuse of this option can yield some very hard-to-find
C     bugs.  Use it with care.
C
C   2
C   -
C     The algorithm that solves the bounded least squares problem
C     iteratively drops columns from the active set. This has the
C     effect of joining a new column vector to the QR factorization of
C     the rectangular matrix consisting of the partially triangularized
C     nonactive columns. After triangularizing this matrix a test is
C     made on the size of the pivot element. The column vector is
C     rejected as dependent if the magnitude of the pivot element is
C     .le. TOL* magnitude of the column in components strictly above
C     the pivot element. Nominally the value of this (rank) tolerance
C     is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for
C     example,
C
C       X(NCOLS+1)=TOL
C       IOPT(1)=2
C       IOPT(2)=1
C       IOPT(3)=99
C       CALL SBOLSM
C
C     Generally, if LP is the processing pointer for IOPT(*),
C
C       X(NCOLS+IOFF)=TOL
C       IOPT(LP)=2
C       IOPT(LP+1)=IOFF
C        .
C       CALL SBOLSM
C
C     The required length of IOPT(*) is increased by 2 if option 2 is
C     used; The required length of X(*) is increased by 1. A value of
C     IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a
C     warning message; it is not considered an error.
C
C   3
C   -
C     A solution component is left active (not used) if, roughly
C     speaking, it seems too large. Mathematically the new component is
C     left active if the magnitude is .ge.((vector norm of F)/(matrix
C     norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)).
C     To change only the value of BLOWUP, for example,
C
C       X(NCOLS+2)=BLOWUP
C       IOPT(1)=3
C       IOPT(2)=2
C       IOPT(3)=99
C       CALL SBOLSM
C
C     Generally, if LP is the processing pointer for IOPT(*),
C
C       X(NCOLS+IOFF)=BLOWUP
C       IOPT(LP)=3
C       IOPT(LP+1)=IOFF
C        .
C       CALL SBOLSM
C
C     The required length of IOPT(*) is increased by 2 if option 3 is
C     used; the required length of X(*) is increased by 1. A value of
C     IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error.
C
C   4
C   -
C     Normally the algorithm for solving the bounded least squares
C     problem requires between NCOLS/3 and NCOLS drop-add steps to
C     converge. (this remark is based on examining a small number of
C     test cases.) The amount of arithmetic for such problems is
C     typically about twice that required for linear least squares if
C     there are no bounds and if plane rotations are used in the
C     solution method. Convergence of the algorithm, while
C     mathematically certain, can be much slower than indicated. To
C     avoid this potential but unlikely event ITMAX drop-add steps are
C     permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the
C     value of ITMAX, for example,
C
C       IOPT(1)=4
C       IOPT(2)=ITMAX
C       IOPT(3)=99
C       CALL SBOLSM
C
C     Generally, if LP is the processing pointer for IOPT(*),
C
C       IOPT(LP)=4
C       IOPT(LP+1)=ITMAX
C        .
C       CALL SBOLSM
C
C     The value of ITMAX must be .gt. 0. Other values are errors. Use
C     of this option increases the required length of IOPT(*) by 2.
C
C   5
C   -
C     For purposes of increased efficiency the MINPUT by NCOLS+1 data
C     matrix [E:F] is triangularized as a first step whenever MINPUT
C     satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the
C     value of FAC,
C
C       X(NCOLS+3)=FAC
C       IOPT(1)=5
C       IOPT(2)=3
C       IOPT(3)=99
C       CALL SBOLSM
C
C     Generally, if LP is the processing pointer for IOPT(*),
C
C       X(NCOLS+IOFF)=FAC
C       IOPT(LP)=5
C       IOPT(LP+1)=IOFF
C        .
C       CALL SBOLSM
C
C     The value of FAC must be nonnegative. Other values are errors.
C     Resetting FAC=0.0 suppresses the initial triangularization step.
C     Use of this option increases the required length of IOPT(*) by 2;
C     The required length of of X(*) is increased by 1.
C
C   6
C   -
C     The norm used in testing the magnitudes of the pivot element
C     compared to the mass of the column above the pivot line can be
C     changed. The type of change that this option allows is to weight
C     the components with an index larger than MVAL by the parameter
C     WT. Normally MVAL=0 and WT=1. To change both the values MVAL and
C     WT, where LP is the processing pointer for IOPT(*),
C
C       X(NCOLS+IOFF)=WT
C       IOPT(LP)=6
C       IOPT(LP+1)=IOFF
C       IOPT(LP+2)=MVAL
C
C     Use of this option increases the required length of IOPT(*) by 3.
C     The length of X(*) is increased by 1. Values of MVAL must be
C     nonnegative and not greater than MINPUT. Other values are errors.
C     The value of WT must be positive. Any other value is an error. If
C     either error condition is present a message will be printed.
C
C   7
C   -
C     Debug output, showing the detailed add-drop steps for the
C     constrained least squares problem, is desired. This option is
C     intended to be used to locate suspected bugs.
C
C   99
C   --
C     There are no more options to change.
C
C     The values for options are 1,...,7,99, and are the only ones
C     permitted. Other values are errors. Options -99,-1,...,-7 mean
C     that the repective options 99,1,...,7 are left at their default
C     values. An example is the option to modify the (rank) tolerance:
C
C       X(NCOLS+1)=TOL
C       IOPT(1)=-2
C       IOPT(2)=1
C       IOPT(3)=99
C
C    Error Messages for SBOLSM
C    ----- -------- --- ---------
C    -22    MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST
C           SQUARES PROBLEM.
C
C    -23    THE OPTION NUMBER = ... IS NOT DEFINED.
C
C    -24    THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE
C           FOR OPTION NUMBER 2.
C
C    -25    THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN
C           MACHINE PRECISION = ....
C
C    -26    THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE
C           FOR OPTION NUMBER 3.
C
C    -27    THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES
C           MUST BE POSITIVE. NOW = ....
C
C    -28    THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE.
C
C    -29    THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE
C           FOR OPTION NUMBER 5.
C
C    -30    THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS
C           PERFORMED MUST BE NONNEGATIVE. NOW = ....
C
C    -31    THE NUMBER OF ROWS = ... MUST BE POSITIVE.
C
C    -32    THE NUMBER OF COLUMNS = ... MUST BE POSTIVE.
C
C    -33    THE ROW DIMENSION OF W(,) = ... MUST BE .GE. THE NUMBER OF
C           ROWS = ....
C
C    -34    FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4.
C
C    -35    FOR J = ... THE LOWER BOUND = ... IS .GT. THE UPPER BOUND =
C           ....
C
C    -36    THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS
C           = ....
C
C    -37    THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE
C           POSITIVE. NOW = ....
C
C    -38    THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN
C           0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE.
C
C***SEE ALSO  SBOCLS, SBOLS
C***ROUTINES CALLED  IVOUT, R1MACH, SAXPY, SCOPY, SDOT, SMOUT, SNRM2,
C                    SROT, SROTG, SSWAP, SVOUT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   821220  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920422  Fixed usage of MINPUT.  (WRB)
C   901009  Editorial changes, code now reads from top to bottom.  (RWC)
C***END PROLOGUE  SBOLSM
C
C     PURPOSE
C     -------
C     THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED
C     LEAST SQUARES PROBLEM.  THE PROBLEM SOLVED HERE IS:
C
C     SOLVE E*X =  F  (LEAST SQUARES SENSE)
C     WITH BOUNDS ON SELECTED X VALUES.
C
C     TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN
C     EDITING AT THE CARD 'C++'.
C     CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS
C     /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/,
C     /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/,
C     /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/,
C     /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/,
C     /SSWAP/ TO /DSWAP/, /E0/ TO /D0/,
C     /REAL            / TO /DOUBLE PRECISION/.
C++
C
      REAL W(MDW,*),BL(*),BU(*)
      REAL X(*),RW(*),WW(*),SCL(*)
      REAL ALPHA,BETA,BOU,COLABV,COLBLO
      REAL CL1,CL2,CL3,ONE,BIG
      REAL FAC,RNORM,SC,SS,T,TOLIND,WT
      REAL TWO,T1,T2,WBIG,WLARGE,WMAG,XNEW
      REAL ZERO,SDOT,SNRM2
      REAL R1MACH,TOLSZE
      INTEGER IBASIS(*),IBB(*),IND(*),IOPT(*)
      LOGICAL FOUND,CONSTR
      CHARACTER*8 XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
C
      PARAMETER (ZERO=0.0E0, ONE=1.0E0, TWO=2.0E0)
C
      INEXT(IDUM) = MIN(IDUM+1,MROWS)
C***FIRST EXECUTABLE STATEMENT  SBOLSM
C
C     Verify that the problem dimensions are defined properly.
C
      IF (MINPUT.LE.0) THEN
          WRITE (XERN1, '(I8)') MINPUT
          CALL XERMSG ('SLATEC', 'SBOLSM', 'THE NUMBER OF ROWS = ' //
     *       XERN1 // ' MUST BE POSITIVE.', 31, 1)
          MODE = -31
          RETURN
      ENDIF
C
      IF (NCOLS.LE.0) THEN
          WRITE (XERN1, '(I8)') NCOLS
          CALL XERMSG ('SLATEC', 'SBOLSM', 'THE NUMBER OF COLUMNS = ' //
     *       XERN1 // ' MUST BE POSITIVE.', 32, 1)
          MODE = -32
          RETURN
      ENDIF
C
      IF (MDW.LT.MINPUT) THEN
          WRITE (XERN1, '(I8)') MDW
          WRITE (XERN2, '(I8)') MINPUT
          CALL XERMSG ('SLATEC', 'SBOLSM',
     *       'THE ROW DIMENSION OF W(,) = ' // XERN1 //
     *       ' MUST BE .GE. THE NUMBER OF ROWS = ' // XERN2, 33, 1)
          MODE = -33
          RETURN
      ENDIF
C
C     Verify that bound information is correct.
C
      DO 10 J = 1,NCOLS
          IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN
              WRITE (XERN1, '(I8)') J
              WRITE (XERN2, '(I8)') IND(J)
              CALL XERMSG ('SLATEC', 'SBOLSM', 'FOR J = ' // XERN1 //
     *           ' THE CONSTRAINT INDICATOR MUST BE 1-4', 34, 1)
              MODE = -34
              RETURN
          ENDIF
   10 CONTINUE
C
      DO 20 J = 1,NCOLS
          IF (IND(J).EQ.3) THEN
              IF (BU(J).LT.BL(J)) THEN
                  WRITE (XERN1, '(I8)') J
                  WRITE (XERN3, '(1PE15.6)') BL(J)
                  WRITE (XERN4, '(1PE15.6)') BU(J)
                  CALL XERMSG ('SLATEC', 'SBOLSM', 'FOR J = ' // XERN1
     *               // ' THE LOWER BOUND = ' // XERN3 //
     *               ' IS .GT. THE UPPER BOUND = ' // XERN4, 35, 1)
                  MODE = -35
                  RETURN
              ENDIF
          ENDIF
   20 CONTINUE
C
C     Check that permutation and polarity arrays have been set.
C
      DO 30 J = 1,NCOLS
          IF (IBASIS(J).LT.1 .OR. IBASIS(J).GT.NCOLS) THEN
              WRITE (XERN1, '(I8)') IBASIS(J)
              WRITE (XERN2, '(I8)') NCOLS
              CALL XERMSG ('SLATEC', 'SBOLSM',
     *           'THE INPUT ORDER OF COLUMNS = ' // XERN1 //
     *           ' IS NOT BETWEEN 1 AND NCOLS = ' // XERN2, 36, 1)
              MODE = -36
              RETURN
          ENDIF
C
          IF (IBB(J).LE.0) THEN
              WRITE (XERN1, '(I8)') J
              WRITE (XERN2, '(I8)') IBB(J)
              CALL XERMSG ('SLATEC', 'SBOLSM',
     *           'THE BOUND POLARITY FLAG IN COMPONENT J = ' // XERN1 //
     *           ' MUST BE POSITIVE.$$NOW = ' // XERN2, 37, 1)
              MODE = -37
              RETURN
          ENDIF
   30 CONTINUE
C
C     Process the option array.
C
      FAC = 0.75E0
      TOLIND = SQRT(R1MACH(4))
      TOLSZE = SQRT(R1MACH(4))
      ITMAX = 5*MAX(MINPUT,NCOLS)
      WT = ONE
      MVAL = 0
      IPRINT = 0
C
C     Changes to some parameters can occur through the option array,
C     IOPT(*).  Process this array looking carefully for input data
C     errors.
C
      LP = 0
      LDS = 0
C
C     Test for no more options.
C
  590 LP = LP + LDS
      IP = IOPT(LP+1)
      JP = ABS(IP)
      IF (IP.EQ.99) THEN
          GO TO 470
      ELSE IF (JP.EQ.99) THEN
          LDS = 1
      ELSE IF (JP.EQ.1) THEN
C
C         Move the IOPT(*) processing pointer.
C
          IF (IP.GT.0) THEN
              LP = IOPT(LP+2) - 1
              LDS = 0
          ELSE
              LDS = 2
          ENDIF
      ELSE IF (JP.EQ.2) THEN
C
C         Change tolerance for rank determination.
C
          IF (IP.GT.0) THEN
              IOFF = IOPT(LP+2)
              IF (IOFF.LE.0) THEN
                  WRITE (XERN1, '(I8)') IOFF
                  WRITE (XERN2, '(I8)') NCOLS
                  CALL XERMSG ('SLATEC', 'SBOLSM', 'THE OFFSET = ' //
     *               XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 //
     *               ' MUST BE POSITIVE FOR OPTION NUMBER 2.', 24, 1)
                  MODE = -24
                  RETURN
              ENDIF
C
              TOLIND = X(NCOLS+IOFF)
              IF (TOLIND.LT.R1MACH(4)) THEN
                  WRITE (XERN3, '(1PE15.6)') TOLIND
                  WRITE (XERN4, '(1PE15.6)') R1MACH(4)
                  CALL XERMSG ('SLATEC', 'SBOLSM',
     *               'THE TOLERANCE FOR RANK DETERMINATION = ' // XERN3
     *               // ' IS LESS THAN MACHINE PRECISION = ' // XERN4,
     *               25, 0)
                  MODE = -25
              ENDIF
          ENDIF
          LDS = 2
      ELSE IF (JP.EQ.3) THEN
C
C         Change blowup factor for allowing variables to become
C         inactive.
C
          IF (IP.GT.0) THEN
              IOFF = IOPT(LP+2)
              IF (IOFF.LE.0) THEN
                  WRITE (XERN1, '(I8)') IOFF
                  WRITE (XERN2, '(I8)') NCOLS
                  CALL XERMSG ('SLATEC', 'SBOLSM', 'THE OFFSET = ' //
     *               XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 //
     *               ' MUST BE POSITIVE FOR OPTION NUMBER 3.', 26, 1)
                  MODE = -26
                  RETURN
              ENDIF
C
              TOLSZE = X(NCOLS+IOFF)
              IF (TOLSZE.LE.ZERO) THEN
                  WRITE (XERN3, '(1PE15.6)') TOLSZE
                  CALL XERMSG ('SLATEC', 'SBOLSM', 'THE RECIPROCAL ' //
     *               'OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES ' //
     *               'MUST BE POSITIVE.$$NOW = ' // XERN3, 27, 1)
                  MODE = -27
                  RETURN
              ENDIF
          ENDIF
          LDS = 2
      ELSE IF (JP.EQ.4) THEN
C
C         Change the maximum number of iterations allowed.
C
          IF (IP.GT.0) THEN
              ITMAX = IOPT(LP+2)
              IF (ITMAX.LE.0) THEN
                  WRITE (XERN1, '(I8)') ITMAX
                  CALL XERMSG ('SLATEC', 'SBOLSM',
     *               'THE MAXIMUM NUMBER OF ITERATIONS = ' // XERN1 //
     *               ' MUST BE POSITIVE.', 28, 1)
                  MODE = -28
                  RETURN
              ENDIF
          ENDIF
          LDS = 2
      ELSE IF (JP.EQ.5) THEN
C
C         Change the factor for pretriangularizing the data matrix.
C
          IF (IP.GT.0) THEN
              IOFF = IOPT(LP+2)
              IF (IOFF.LE.0) THEN
                  WRITE (XERN1, '(I8)') IOFF
                  WRITE (XERN2, '(I8)') NCOLS
                  CALL XERMSG ('SLATEC', 'SBOLSM', 'THE OFFSET = ' //
     *               XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 //
     *               ' MUST BE POSITIVE FOR OPTION NUMBER 5.', 29, 1)
                  MODE = -29
                  RETURN
              ENDIF
C
              FAC = X(NCOLS+IOFF)
              IF (FAC.LT.ZERO) THEN
                  WRITE (XERN3, '(1PE15.6)') FAC
                  CALL XERMSG ('SLATEC', 'SBOLSM',
     *               'THE FACTOR (NCOLS/MINPUT) WHERE PRE-' //
     *               'TRIANGULARIZING IS PERFORMED MUST BE NON-' //
     *               'NEGATIVE.$$NOW = ' // XERN3, 30, 0)
                  MODE = -30
                  RETURN
              ENDIF
          ENDIF
          LDS = 2
      ELSE IF (JP.EQ.6) THEN
C
C         Change the weighting factor (from 1.0) to apply to components
C         numbered .gt. MVAL (initially set to 1.)  This trick is needed
C         for applications of this subprogram to the heavily weighted
C         least squares problem that come from equality constraints.
C
          IF (IP.GT.0) THEN
              IOFF = IOPT(LP+2)
              MVAL = IOPT(LP+3)
              WT = X(NCOLS+IOFF)
          ENDIF
C
          IF (MVAL.LT.0 .OR. MVAL.GT.MINPUT .OR. WT.LE.ZERO) THEN
              WRITE (XERN1, '(I8)') MVAL
              WRITE (XERN2, '(I8)') MINPUT
              WRITE (XERN3, '(1PE15.6)') WT
              CALL XERMSG ('SLATEC', 'SBOLSM',
     *           'THE ROW SEPARATOR TO APPLY WEIGHTING (' // XERN1 //
     *           ') MUST LIE BETWEEN 0 AND MINPUT = ' // XERN2 //
     *           '.$$WEIGHT = ' // XERN3 // ' MUST BE POSITIVE.', 38, 0)
              MODE = -38
              RETURN
          ENDIF
          LDS = 3
      ELSE IF (JP.EQ.7) THEN
C
C         Turn on debug output.
C
          IF (IP.GT.0) IPRINT = 1
          LDS = 2
      ELSE
          WRITE (XERN1, '(I8)') IP
          CALL XERMSG ('SLATEC', 'SBOLSM', 'THE OPTION NUMBER = ' //
     *       XERN1 // ' IS NOT DEFINED.', 23, 1)
          MODE = -23
          RETURN
      ENDIF
      GO TO 590
C
C     Pretriangularize rectangular arrays of certain sizes for
C     increased efficiency.
C
  470 IF (FAC*MINPUT.GT.NCOLS) THEN
          DO 490 J = 1,NCOLS+1
              DO 480 I = MINPUT,J+MVAL+1,-1
                  CALL SROTG(W(I-1,J),W(I,J),SC,SS)
                  W(I,J) = ZERO
                  CALL SROT(NCOLS-J+1,W(I-1,J+1),MDW,W(I,J+1),MDW,SC,SS)
  480         CONTINUE
  490     CONTINUE
          MROWS = NCOLS + MVAL + 1
      ELSE
          MROWS = MINPUT
      ENDIF
C
C     Set the X(*) array to zero so all components are defined.
C
      CALL SCOPY(NCOLS,ZERO,0,X,1)
C
C     The arrays IBASIS(*) and IBB(*) are initialized by the calling
C     program and the column scaling is defined in the calling program.
C     'BIG' is plus infinity on this machine.
C
      BIG = R1MACH(2)
      DO 550 J = 1,NCOLS
          IF (IND(J).EQ.1) THEN
              BU(J) = BIG
          ELSE IF (IND(J).EQ.2) THEN
              BL(J) = -BIG
          ELSE IF (IND(J).EQ.4) THEN
              BL(J) = -BIG
              BU(J) = BIG
          ENDIF
  550 CONTINUE
C
      DO 570 J = 1,NCOLS
          IF ((BL(J).LE.ZERO.AND.ZERO.LE.BU(J).AND.ABS(BU(J)).LT.
     *        ABS(BL(J))) .OR. BU(J).LT.ZERO) THEN
              T = BU(J)
              BU(J) = -BL(J)
              BL(J) = -T
              SCL(J) = -SCL(J)
              DO 560 I = 1,MROWS
                  W(I,J) = -W(I,J)
  560         CONTINUE
          ENDIF
C
C         Indices in set T(=TIGHT) are denoted by negative values
C         of IBASIS(*).
C
          IF (BL(J).GE.ZERO) THEN
              IBASIS(J) = -IBASIS(J)
              T = -BL(J)
              BU(J) = BU(J) + T
              CALL SAXPY(MROWS,T,W(1,J),1,W(1,NCOLS+1),1)
          ENDIF
  570 CONTINUE
C
      NSETB = 0
      ITER = 0
C
      IF (IPRINT.GT.0) THEN
          CALL SMOUT(MROWS,NCOLS+1,MDW,W,'('' PRETRI. INPUT MATRIX'')',
     *               -4)
          CALL SVOUT(NCOLS,BL,'('' LOWER BOUNDS'')',-4)
          CALL SVOUT(NCOLS,BU,'('' UPPER BOUNDS'')',-4)
      ENDIF
C
  580 ITER = ITER + 1
      IF (ITER.GT.ITMAX) THEN
         WRITE (XERN1, '(I8)') ITMAX
         CALL XERMSG ('SLATEC', 'SBOLSM', 'MORE THAN ITMAX = ' // XERN1
     *      // ' ITERATIONS SOLVING BOUNDED LEAST SQUARES PROBLEM.',
     *      22, 1)
         MODE = -22
C
C        Rescale and translate variables.
C
         IGOPR = 1
         GO TO 130
      ENDIF
C
C     Find a variable to become non-active.
C                                                 T
C     Compute (negative) of gradient vector, W = E *(F-E*X).
C
      CALL SCOPY(NCOLS,ZERO,0,WW,1)
      DO 200 J = NSETB+1,NCOLS
          JCOL = ABS(IBASIS(J))
          WW(J) = SDOT(MROWS-NSETB,W(INEXT(NSETB),J),1,
     *            W(INEXT(NSETB),NCOLS+1),1)*ABS(SCL(JCOL))
  200 CONTINUE
C
      IF (IPRINT.GT.0) THEN
          CALL SVOUT(NCOLS,WW,'('' GRADIENT VALUES'')',-4)
          CALL IVOUT(NCOLS,IBASIS,'('' INTERNAL VARIABLE ORDER'')',-4)
          CALL IVOUT(NCOLS,IBB,'('' BOUND POLARITY'')',-4)
      ENDIF
C
C     If active set = number of total rows, quit.
C
  210 IF (NSETB.EQ.MROWS) THEN
          FOUND = .FALSE.
          GO TO 120
      ENDIF
C
C     Choose an extremal component of gradient vector for a candidate
C     to become non-active.
C
      WLARGE = -BIG
      WMAG = -BIG
      DO 220 J = NSETB+1,NCOLS
          T = WW(J)
          IF (T.EQ.BIG) GO TO 220
          ITEMP = IBASIS(J)
          JCOL = ABS(ITEMP)
          T1 = SNRM2(MVAL-NSETB,W(INEXT(NSETB),J),1)
          IF (ITEMP.LT.0) THEN
              IF (MOD(IBB(JCOL),2).EQ.0) T = -T
              IF (T.LT.ZERO) GO TO 220
              IF (MVAL.GT.NSETB) T = T1
              IF (T.GT.WLARGE) THEN
                  WLARGE = T
                  JLARGE = J
              ENDIF
          ELSE
              IF (MVAL.GT.NSETB) T = T1
              IF (ABS(T).GT.WMAG) THEN
                  WMAG = ABS(T)
                  JMAG = J
              ENDIF
          ENDIF
  220 CONTINUE
C
C     Choose magnitude of largest component of gradient for candidate.
C
      JBIG = 0
      WBIG = ZERO
      IF (WLARGE.GT.ZERO) THEN
          JBIG = JLARGE
          WBIG = WLARGE
      ENDIF
C
      IF (WMAG.GE.WBIG) THEN
          JBIG = JMAG
          WBIG = WMAG
      ENDIF
C
      IF (JBIG.EQ.0) THEN
          FOUND = .FALSE.
          IF (IPRINT.GT.0) THEN
              CALL IVOUT(0,I,'('' FOUND NO VARIABLE TO ENTER'')',-4)
          ENDIF
          GO TO 120
      ENDIF
C
C     See if the incoming column is sufficiently independent.  This
C     test is made before an elimination is performed.
C
      IF (IPRINT.GT.0)
     *    CALL IVOUT(1,JBIG,'('' TRY TO BRING IN THIS COL.'')',-4)
C
      IF (MVAL.LE.NSETB) THEN
          CL1 = SNRM2(MVAL,W(1,JBIG),1)
          CL2 = ABS(WT)*SNRM2(NSETB-MVAL,W(INEXT(MVAL),JBIG),1)
          CL3 = ABS(WT)*SNRM2(MROWS-NSETB,W(INEXT(NSETB),JBIG),1)
          CALL SROTG(CL1,CL2,SC,SS)
          COLABV = ABS(CL1)
          COLBLO = CL3
      ELSE
          CL1 = SNRM2(NSETB,W(1,JBIG),1)
          CL2 = SNRM2(MVAL-NSETB,W(INEXT(NSETB),JBIG),1)
          CL3 = ABS(WT)*SNRM2(MROWS-MVAL,W(INEXT(MVAL),JBIG),1)
          COLABV = CL1
          CALL SROTG(CL2,CL3,SC,SS)
          COLBLO = ABS(CL2)
      ENDIF
C
      IF (COLBLO.LE.TOLIND*COLABV) THEN
          WW(JBIG) = BIG
          IF (IPRINT.GT.0)
     *        CALL IVOUT(0,I,'('' VARIABLE IS DEPENDENT, NOT USED.'')',
     *           -4)
          GO TO 210
      ENDIF
C
C     Swap matrix columns NSETB+1 and JBIG, plus pointer information,
C     and gradient values.
C
      NSETB = NSETB + 1
      IF (NSETB.NE.JBIG) THEN
          CALL SSWAP(MROWS,W(1,NSETB),1,W(1,JBIG),1)
          CALL SSWAP(1,WW(NSETB),1,WW(JBIG),1)
          ITEMP = IBASIS(NSETB)
          IBASIS(NSETB) = IBASIS(JBIG)
          IBASIS(JBIG) = ITEMP
      ENDIF
C
C     Eliminate entries below the pivot line in column NSETB.
C
      IF (MROWS.GT.NSETB) THEN
          DO 230 I = MROWS,NSETB+1,-1
              IF (I.EQ.MVAL+1) GO TO 230
              CALL SROTG(W(I-1,NSETB),W(I,NSETB),SC,SS)
              W(I,NSETB) = ZERO
              CALL SROT(NCOLS-NSETB+1,W(I-1,NSETB+1),MDW,W(I,NSETB+1),
     *                  MDW,SC,SS)
  230     CONTINUE
C
          IF (MVAL.GE.NSETB .AND. MVAL.LT.MROWS) THEN
              CALL SROTG(W(NSETB,NSETB),W(MVAL+1,NSETB),SC,SS)
              W(MVAL+1,NSETB) = ZERO
              CALL SROT(NCOLS-NSETB+1,W(NSETB,NSETB+1),MDW,
     *                  W(MVAL+1,NSETB+1),MDW,SC,SS)
          ENDIF
      ENDIF
C
      IF (W(NSETB,NSETB).EQ.ZERO) THEN
          WW(NSETB) = BIG
          NSETB = NSETB - 1
          IF (IPRINT.GT.0) THEN
              CALL IVOUT(0,I,'('' PIVOT IS ZERO, NOT USED.'')',-4)
          ENDIF
          GO TO 210
      ENDIF
C
C     Check that new variable is moving in the right direction.
C
      ITEMP = IBASIS(NSETB)
      JCOL = ABS(ITEMP)
      XNEW = (W(NSETB,NCOLS+1)/W(NSETB,NSETB))/ABS(SCL(JCOL))
      IF (ITEMP.LT.0) THEN
C
C         IF(WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) exit(quit)
C         IF(WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) exit(quit)
C
          IF ((WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) .OR.
     *        (WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO)) GO TO 240
      ENDIF
      FOUND = .TRUE.
      GO TO 120
C
  240 WW(NSETB) = BIG
      NSETB = NSETB - 1
      IF (IPRINT.GT.0)
     *    CALL IVOUT(0,I,'('' VARIABLE HAS BAD DIRECTION, NOT USED.'')',
     *       -4)
      GO TO 210
C
C     Solve the triangular system.
C
  270 CALL SCOPY(NSETB,W(1,NCOLS+1),1,RW,1)
      DO 280 J = NSETB,1,-1
          RW(J) = RW(J)/W(J,J)
          JCOL = ABS(IBASIS(J))
          T = RW(J)
          IF (MOD(IBB(JCOL),2).EQ.0) RW(J) = -RW(J)
          CALL SAXPY(J-1,-T,W(1,J),1,RW,1)
          RW(J) = RW(J)/ABS(SCL(JCOL))
  280 CONTINUE
C
      IF (IPRINT.GT.0) THEN
          CALL SVOUT(NSETB,RW,'('' SOLN. VALUES'')',-4)
          CALL IVOUT(NSETB,IBASIS,'('' COLS. USED'')',-4)
      ENDIF
C
      IF (LGOPR.EQ.2) THEN
          CALL SCOPY(NSETB,RW,1,X,1)
          DO 450 J = 1,NSETB
              ITEMP = IBASIS(J)
              JCOL = ABS(ITEMP)
              IF (ITEMP.LT.0) THEN
                  BOU = ZERO
              ELSE
                  BOU = BL(JCOL)
              ENDIF
C
              IF ((-BOU).NE.BIG) BOU = BOU/ABS(SCL(JCOL))
              IF (X(J).LE.BOU) THEN
                  JDROP1 = J
                  GO TO 340
              ENDIF
C
              BOU = BU(JCOL)
              IF (BOU.NE.BIG) BOU = BOU/ABS(SCL(JCOL))
              IF (X(J).GE.BOU) THEN
                  JDROP2 = J
                  GO TO 340
              ENDIF
  450     CONTINUE
          GO TO 340
      ENDIF
C
C     See if the unconstrained solution (obtained by solving the
C     triangular system) satisfies the problem bounds.
C
      ALPHA = TWO
      BETA = TWO
      X(NSETB) = ZERO
      DO 310 J = 1,NSETB
          ITEMP = IBASIS(J)
          JCOL = ABS(ITEMP)
          T1 = TWO
          T2 = TWO
          IF (ITEMP.LT.0) THEN
              BOU = ZERO
          ELSE
              BOU = BL(JCOL)
          ENDIF
          IF ((-BOU).NE.BIG) BOU = BOU/ABS(SCL(JCOL))
          IF (RW(J).LE.BOU) T1 = (X(J)-BOU)/ (X(J)-RW(J))
          BOU = BU(JCOL)
          IF (BOU.NE.BIG) BOU = BOU/ABS(SCL(JCOL))
          IF (RW(J).GE.BOU) T2 = (BOU-X(J))/ (RW(J)-X(J))
C
C     If not, then compute a step length so that the variables remain
C     feasible.
C
          IF (T1.LT.ALPHA) THEN
              ALPHA = T1
              JDROP1 = J
          ENDIF
C
          IF (T2.LT.BETA) THEN
              BETA = T2
              JDROP2 = J
          ENDIF
  310 CONTINUE
C
      CONSTR = ALPHA .LT. TWO .OR. BETA .LT. TWO
      IF (.NOT.CONSTR) THEN
C
C         Accept the candidate because it satisfies the stated bounds
C         on the variables.
C
          CALL SCOPY(NSETB,RW,1,X,1)
          GO TO 580
      ENDIF
C
C     Take a step that is as large as possible with all variables
C     remaining feasible.
C
      DO 330 J = 1,NSETB
          X(J) = X(J) + MIN(ALPHA,BETA)* (RW(J)-X(J))
  330 CONTINUE
C
      IF (ALPHA.LE.BETA) THEN
          JDROP2 = 0
      ELSE
          JDROP1 = 0
      ENDIF
C
  340 IF (JDROP1+JDROP2.LE.0 .OR. NSETB.LE.0) GO TO 580
  350 JDROP = JDROP1 + JDROP2
      ITEMP = IBASIS(JDROP)
      JCOL = ABS(ITEMP)
      IF (JDROP2.GT.0) THEN
C
C         Variable is at an upper bound.  Subtract multiple of this
C         column from right hand side.
C
          T = BU(JCOL)
          IF (ITEMP.GT.0) THEN
              BU(JCOL) = T - BL(JCOL)
              BL(JCOL) = -T
              ITEMP = -ITEMP
              SCL(JCOL) = -SCL(JCOL)
              DO 360 I = 1,JDROP
                  W(I,JDROP) = -W(I,JDROP)
  360         CONTINUE
          ELSE
              IBB(JCOL) = IBB(JCOL) + 1
              IF (MOD(IBB(JCOL),2).EQ.0) T = -T
          ENDIF
C
C     Variable is at a lower bound.
C
      ELSE
          IF (ITEMP.LT.ZERO) THEN
              T = ZERO
          ELSE
              T = -BL(JCOL)
              BU(JCOL) = BU(JCOL) + T
              ITEMP = -ITEMP
          ENDIF
      ENDIF
C
      CALL SAXPY(JDROP,T,W(1,JDROP),1,W(1,NCOLS+1),1)
C
C     Move certain columns left to achieve upper Hessenberg form.
C
      CALL SCOPY(JDROP,W(1,JDROP),1,RW,1)
      DO 370 J = JDROP+1,NSETB
          IBASIS(J-1) = IBASIS(J)
          X(J-1) = X(J)
          CALL SCOPY(J,W(1,J),1,W(1,J-1),1)
  370 CONTINUE
C
      IBASIS(NSETB) = ITEMP
      W(1,NSETB) = ZERO
      CALL SCOPY(MROWS-JDROP,W(1,NSETB),0,W(JDROP+1,NSETB),1)
      CALL SCOPY(JDROP,RW,1,W(1,NSETB),1)
C
C     Transform the matrix from upper Hessenberg form to upper
C     triangular form.
C
      NSETB = NSETB - 1
      DO 390 I = JDROP,NSETB
C
C         Look for small pivots and avoid mixing weighted and
C         nonweighted rows.
C
          IF (I.EQ.MVAL) THEN
              T = ZERO
              DO 380 J = I,NSETB
                  JCOL = ABS(IBASIS(J))
                  T1 = ABS(W(I,J)*SCL(JCOL))
                  IF (T1.GT.T) THEN
                      JBIG = J
                      T = T1
                  ENDIF
  380         CONTINUE
              GO TO 400
          ENDIF
          CALL SROTG(W(I,I),W(I+1,I),SC,SS)
          W(I+1,I) = ZERO
          CALL SROT(NCOLS-I+1,W(I,I+1),MDW,W(I+1,I+1),MDW,SC,SS)
  390 CONTINUE
      GO TO 430
C
C     The triangularization is completed by giving up the Hessenberg
C     form and triangularizing a rectangular matrix.
C
  400 CALL SSWAP(MROWS,W(1,I),1,W(1,JBIG),1)
      CALL SSWAP(1,WW(I),1,WW(JBIG),1)
      CALL SSWAP(1,X(I),1,X(JBIG),1)
      ITEMP = IBASIS(I)
      IBASIS(I) = IBASIS(JBIG)
      IBASIS(JBIG) = ITEMP
      JBIG = I
      DO 420 J = JBIG,NSETB
          DO 410 I = J+1,MROWS
              CALL SROTG(W(J,J),W(I,J),SC,SS)
              W(I,J) = ZERO
              CALL SROT(NCOLS-J+1,W(J,J+1),MDW,W(I,J+1),MDW,SC,SS)
  410     CONTINUE
  420 CONTINUE
C
C     See if the remaining coefficients are feasible.  They should be
C     because of the way MIN(ALPHA,BETA) was chosen.  Any that are not
C     feasible will be set to their bounds and appropriately translated.
C
  430 JDROP1 = 0
      JDROP2 = 0
      LGOPR = 2
      GO TO 270
C
C     Find a variable to become non-active.
C
  120 IF (FOUND) THEN
          LGOPR = 1
          GO TO 270
      ENDIF
C
C     Rescale and translate variables.
C
      IGOPR = 2
  130 CALL SCOPY(NSETB,X,1,RW,1)
      CALL SCOPY(NCOLS,ZERO,0,X,1)
      DO 140 J = 1,NSETB
          JCOL = ABS(IBASIS(J))
          X(JCOL) = RW(J)*ABS(SCL(JCOL))
  140 CONTINUE
C
      DO 150 J = 1,NCOLS
          IF (MOD(IBB(J),2).EQ.0) X(J) = BU(J) - X(J)
  150 CONTINUE
C
      DO 160 J = 1,NCOLS
          JCOL = IBASIS(J)
          IF (JCOL.LT.0) X(-JCOL) = BL(-JCOL) + X(-JCOL)
  160 CONTINUE
C
      DO 170 J = 1,NCOLS
          IF (SCL(J).LT.ZERO) X(J) = -X(J)
  170 CONTINUE
C
      I = MAX(NSETB,MVAL)
      RNORM = SNRM2(MROWS-I,W(INEXT(I),NCOLS+1),1)
C
      IF (IGOPR.EQ.2) MODE = NSETB
      RETURN
      END
