*DECK SODS
      SUBROUTINE SODS (A, X, B, NEQ, NUK, NRDA, IFLAG, WORK, IWORK)
C***BEGIN PROLOGUE  SODS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SODS-S)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     SODS solves the overdetermined system of linear equations A X = B,
C     where A is NEQ by NUK and NEQ .GE. NUK. If rank A = NUK,
C     X is the UNIQUE least squares solution vector. That is,
C              R(1)**2 + ..... + R(NEQ)**2 = minimum
C     where R is the residual vector  R = B - A X.
C     If rank A .LT. NUK , the least squares solution of minimal
C     length can be provided.
C     SODS is an interfacing routine which calls subroutine LSSODS
C     for the solution. LSSODS in turn calls subroutine ORTHOL and
C     possibly subroutine OHTROR for the decomposition of A by
C     orthogonal transformations. In the process, ORTHOL calls upon
C     subroutine CSCALE for scaling.
C
C **********************************************************************
C   Input
C **********************************************************************
C
C     A -- Contains the matrix of NEQ equations in NUK unknowns and must
C          be dimensioned NRDA by NUK. The original A is destroyed
C     X -- Solution array of length at least NUK
C     B -- Given constant vector of length NEQ, B is destroyed
C     NEQ -- Number of equations, NEQ greater or equal to 1
C     NUK -- Number of columns in the matrix (which is also the number
C            of unknowns), NUK not larger than NEQ
C     NRDA -- Row dimension of A, NRDA greater or equal to NEQ
C     IFLAG -- Status indicator
C            =0 For the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is treated as exact
C           =-K For the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is assumed to be
C               accurate to about K digits
C            =1 For subsequent calls whenever the matrix A has already
C               been decomposed (problems with new vectors B but
C               same matrix a can be handled efficiently)
C     WORK(*),IWORK(*) -- Arrays for storage of internal information,
C                     WORK must be dimensioned at least  2 + 5*NUK
C                     IWORK must be dimensioned at least NUK+2
C     IWORK(2) -- Scaling indicator
C                 =-1 If the matrix A is to be pre-scaled by
C                 columns when appropriate
C                 If the scaling indicator is not equal to -1
C                 no scaling will be attempted
C              For most problems scaling will probably not be necessary
C
C **********************************************************************
C   OUTPUT
C **********************************************************************
C
C     IFLAG -- Status indicator
C            =1 If solution was obtained
C            =2 If improper input is detected
C            =3 If rank of matrix is less than NUK
C               If the minimal length least squares solution is
C               desired, simply reset IFLAG=1 and call the code again
C     X -- Least squares solution of  A X = B
C     A -- Contains the strictly upper triangular part of the reduced
C           matrix and the transformation information
C     WORK(*),IWORK(*) -- Contains information needed on subsequent
C                         Calls (IFLAG=1 case on input) which must not
C                         be altered
C                         WORK(1) contains the Euclidean norm of
C                         the residual vector
C                         WORK(2) contains the Euclidean norm of
C                         the solution vector
C                         IWORK(1) contains the numerically determined
C                         rank of the matrix A
C
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***REFERENCES  G. Golub, Numerical methods for solving linear least
C                 squares problems, Numerische Mathematik 7, (1965),
C                 pp. 206-216.
C               P. Businger and G. Golub, Linear least squares
C                 solutions by Householder transformations, Numerische
C                 Mathematik  7, (1965), pp. 269-276.
C               H. A. Watts, Solving linear least squares problems
C                 using SODS/SUDS/CODS, Sandia Report SAND77-0683,
C                 Sandia Laboratories, 1977.
C***ROUTINES CALLED  LSSODS
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SODS
      DIMENSION A(NRDA,*),X(*),B(*),WORK(*),IWORK(*)
C
C***FIRST EXECUTABLE STATEMENT  SODS
      ITER=0
      IS=2
      IP=3
      KS=2
      KD=3
      KZ=KD+NUK
      KV=KZ+NUK
      KT=KV+NUK
      KC=KT+NUK
C
      CALL LSSODS(A,X,B,NEQ,NUK,NRDA,IFLAG,IWORK(1),IWORK(IS),A,
     1            WORK(KD),IWORK(IP),ITER,WORK(1),WORK(KS),
     2            WORK(KZ),B,WORK(KV),WORK(KT),WORK(KC))
C
      RETURN
      END
*DECK SOMN
      SUBROUTINE SOMN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     +   NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP,
     +   EMAP, DZ, CSAV, RWORK, IWORK)
C***BEGIN PROLOGUE  SOMN
C***PURPOSE  Preconditioned Orthomin Sparse Iterative Ax=b Solver.
C            Routine to solve a general linear system  Ax = b  using
C            the Preconditioned Orthomin method.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2A4, D2B4
C***TYPE      SINGLE PRECISION (SOMN-S, DOMN-D)
C***KEYWORDS  ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM,
C             ORTHOMIN, 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, NSAVE, ITOL, ITMAX
C     INTEGER  ITER, IERR, IUNIT, IWORK(USER DEFINED)
C     REAL     B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N)
C     REAL     P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE)
C     REAL     DZ(N), CSAV(NSAVE), RWORK(USER DEFINED)
C     EXTERNAL MATVEC, MSOLVE
C
C     CALL SOMN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
C    $     NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R,
C    $     Z, P, AP, EMAP, DZ, CSAV, 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         Y = A*X given A and X.  The name of the MATVEC routine must
C         be declared external in the calling program.  The calling
C         sequence to 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
C         upon return X is an input vector, NELT is the number of
C         non-zeros in the SLAP IA, JA, A storage for the matrix A.
C         ISYM is a flag which, if non-zero, denotest that A is
C         symmetric and only the lower or upper triangle is stored.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R for
C         Z given R with the preconditioning matrix M (M is supplied via
C         RWORK and IWORK arrays).  The name of the MSOLVE routine must
C         be declared external in the calling program.  The calling
C         sequence to 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 and
C         ISYM are defined as above.  RWORK is a real array that can
C         be used to pass necessary preconditioning information and/or
C         workspace to MSOLVE.  IWORK is an integer work array for
C         the same purpose as RWORK.
C NSAVE  :IN       Integer.
C         Number of  direction vectors to save and orthogonalize
C         against.  NSAVE >= 0.
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 => Breakdown of method detected.
C                       (p,Ap) < epsilon**2.
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,0:NSAVE).
C AP     :WORK     Real AP(N,0:NSAVE).
C EMAP   :WORK     Real EMAP(N,0:NSAVE).
C DZ     :WORK     Real DZ(N).
C CSAV   :WORK     Real CSAV(NSAVE)
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 IWORK  :WORK     Integer IWORK(USER DEFINED).
C         Integer array that can be used for workspace in MSOLVE.
C
C *Description
C       This routine does  not care  what matrix data   structure is
C       used for  A and M.  It simply   calls  the MATVEC and MSOLVE
C       routines, with  the arguments as  described above.  The user
C       could write any type of structure and the appropriate MATVEC
C       and MSOLVE 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 SSDOMN and SSLUOM 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  SSDOMN, SSLUOM, ISSOMN
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  ISSOMN, 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 and MSOLVE from ROUTINES 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   930326  Removed unused variable.  (FNF)
C***END PROLOGUE  SOMN
C     .. Scalar Arguments ..
      REAL ERR, TOL
      INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE
C     .. Array Arguments ..
      REAL A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), DZ(N),
     +     EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), RWORK(*), X(N), Z(N)
      INTEGER IA(NELT), IWORK(*), JA(NELT)
C     .. Subroutine Arguments ..
      EXTERNAL MATVEC, MSOLVE
C     .. Local Scalars ..
      REAL AK, AKDEN, AKNUM, BKL, BNRM, FUZZ, SOLNRM
      INTEGER I, IP, IPO, K, L, LMAX
C     .. External Functions ..
      REAL R1MACH, SDOT
      INTEGER ISSOMN
      EXTERNAL R1MACH, SDOT, ISSOMN
C     .. External Subroutines ..
      EXTERNAL SAXPY, SCOPY
C     .. Intrinsic Functions ..
      INTRINSIC ABS, MIN, MOD
C***FIRST EXECUTABLE STATEMENT  SOMN
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)
      IF( TOL.LT.500*FUZZ ) THEN
         TOL = 500*FUZZ
         IERR = 4
      ENDIF
      FUZZ = FUZZ*FUZZ
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)
 10   CONTINUE
      CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
      IF( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
     $     R, Z, P, AP, EMAP, DZ, CSAV,
     $     RWORK, IWORK, AK, BNRM, SOLNRM) .NE. 0 ) GO TO 200
      IF( IERR.NE.0 ) RETURN
C
C
C         ***** iteration loop *****
C
CVD$R NOVECTOR
CVD$R NOCONCUR
      DO 100 K = 1, ITMAX
         ITER = K
         IP = MOD( ITER-1, NSAVE+1 )
C
C         calculate direction vector p, a*p, and (m-inv)*a*p,
C         and save if desired.
         CALL SCOPY(N, Z, 1, P(1,IP), 1)
         CALL MATVEC(N, P(1,IP), AP(1,IP), NELT, IA, JA, A, ISYM)
         CALL MSOLVE(N, AP(1,IP), EMAP(1,IP), NELT, IA, JA, A, ISYM,
     $        RWORK, IWORK)
         IF( NSAVE.EQ.0 ) THEN
            AKDEN = SDOT(N, EMAP, 1, EMAP, 1)
         ELSE
            IF( ITER.GT.1 ) THEN
               LMAX = MIN( NSAVE, ITER-1 )
               DO 20 L = 1, LMAX
                  IPO = MOD(IP+(NSAVE+1-L),NSAVE+1)
                  BKL = SDOT(N, EMAP(1,IP), 1, EMAP(1,IPO), 1)
                  BKL = BKL*CSAV(L)
                  CALL SAXPY(N, -BKL,    P(1,IPO), 1,    P(1,IP), 1)
                  CALL SAXPY(N, -BKL,   AP(1,IPO), 1,   AP(1,IP), 1)
                  CALL SAXPY(N, -BKL, EMAP(1,IPO), 1, EMAP(1,IP), 1)
 20            CONTINUE
               IF( NSAVE.GT.1 ) THEN
                  DO 30 L = NSAVE-1, 1, -1
                     CSAV(L+1) = CSAV(L)
 30               CONTINUE
               ENDIF
            ENDIF
            AKDEN = SDOT(N, EMAP(1,IP), 1, EMAP(1,IP), 1)
            IF( ABS(AKDEN).LT.FUZZ ) THEN
               IERR = 6
               RETURN
            ENDIF
            CSAV(1) = 1.0E0/AKDEN
C
C         calculate coefficient ak, new iterate x, new residual r, and
C         new pseudo-residual z.
         ENDIF
         AKNUM = SDOT(N, Z, 1, EMAP(1,IP), 1)
         AK = AKNUM/AKDEN
         CALL SAXPY(N,  AK,    P(1,IP), 1, X, 1)
         CALL SAXPY(N, -AK,   AP(1,IP), 1, R, 1)
         CALL SAXPY(N, -AK, EMAP(1,IP), 1, Z, 1)
C
C         check stopping criterion.
         IF( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE,
     $        ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
     $        R, Z, P, AP, EMAP, DZ, CSAV,
     $        RWORK, IWORK, AK, 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 SOMN FOLLOWS ----------------------------
      END
*DECK SOPENM
      SUBROUTINE SOPENM (IPAGE, LPAGE)
C***BEGIN PROLOGUE  SOPENM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      ALL (SOPENM-A)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     1. OPEN UNIT NUMBER IPAGEF AS A RANDOM ACCESS FILE.
C
C     2. THE RECORD LENGTH IS CONSTANT=LPG.
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890605  Corrected references to XERRWV.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  SOPENM
      CHARACTER*8 XERN1
C
C***FIRST EXECUTABLE STATEMENT  SOPENM
      IPAGEF=IPAGE
      LPG   =LPAGE
      OPEN(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='UNKNOWN',
     *ACCESS='DIRECT',FORM='UNFORMATTED',RECL=LPG)
      RETURN
C
 100  WRITE (XERN1, '(I8)') IOS
      CALL XERMSG ('SLATEC', 'SOPENM',
     *   'IN SPLP, OPEN HAS ERROR FLAG = ' // XERN1, 100, 1)
      RETURN
      END
*DECK SORTH
      SUBROUTINE SORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW)
C***BEGIN PROLOGUE  SORTH
C***SUBSIDIARY
C***PURPOSE  Internal routine for SGMRES.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2A4, D2B4
C***TYPE      SINGLE PRECISION (SORTH-S, DORTH-D)
C***KEYWORDS  GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION,
C             NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE
C***AUTHOR  Brown, Peter, (LLNL), pnbrown@llnl.gov
C           Hindmarsh, Alan, (LLNL), alanh@llnl.gov
C           Seager, Mark K., (LLNL), seager@llnl.gov
C             Lawrence Livermore National Laboratory
C             PO Box 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C***DESCRIPTION
C        This routine  orthogonalizes  the  vector  VNEW  against the
C        previous KMP  vectors in the   V array.  It uses  a modified
C        Gram-Schmidt   orthogonalization procedure with  conditional
C        reorthogonalization.
C
C *Usage:
C      INTEGER N, LL, LDHES, KMP
C      REAL VNEW(N), V(N,LL), HES(LDHES,LL), SNORMW
C
C      CALL SORTH(VNEW, V, HES, N, LL, LDHES, KMP, SNORMW)
C
C *Arguments:
C VNEW   :INOUT    Real VNEW(N)
C         On input, the vector of length N containing a scaled
C         product of the Jacobian and the vector V(*,LL).
C         On output, the new vector orthogonal to V(*,i0) to V(*,LL),
C         where i0 = max(1, LL-KMP+1).
C V      :IN       Real V(N,LL)
C         The N x LL array containing the previous LL
C         orthogonal vectors V(*,1) to V(*,LL).
C HES    :INOUT    Real HES(LDHES,LL)
C         On input, an LL x LL upper Hessenberg matrix containing,
C         in HES(I,K), K.lt.LL, the scaled inner products of
C         A*V(*,K) and V(*,i).
C         On return, column LL of HES is filled in with
C         the scaled inner products of A*V(*,LL) and V(*,i).
C N      :IN       Integer
C         The order of the matrix A, and the length of VNEW.
C LL     :IN       Integer
C         The current order of the matrix HES.
C LDHES  :IN       Integer
C         The leading dimension of the HES array.
C KMP    :IN       Integer
C         The number of previous vectors the new vector VNEW
C         must be made orthogonal to (KMP .le. MAXL).
C SNORMW :OUT      REAL
C         Scalar containing the l-2 norm of VNEW.
C
C***SEE ALSO  SGMRES
C***ROUTINES CALLED  SAXPY, SDOT, SNRM2
C***REVISION HISTORY  (YYMMDD)
C   871001  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   910506  Made subsidiary to SGMRES.  (FNF)
C   920511  Added complete declaration section.  (WRB)
C***END PROLOGUE  SORTH
C         The following is for optimized compilation on LLNL/LTSS Crays.
CLLL. OPTIMIZE
C     .. Scalar Arguments ..
      REAL SNORMW
      INTEGER KMP, LDHES, LL, N
C     .. Array Arguments ..
      REAL HES(LDHES,*), V(N,*), VNEW(*)
C     .. Local Scalars ..
      REAL ARG, SUMDSQ, TEM, VNRM
      INTEGER I, I0
C     .. External Functions ..
      REAL SDOT, SNRM2
      EXTERNAL SDOT, SNRM2
C     .. External Subroutines ..
      EXTERNAL SAXPY
C     .. Intrinsic Functions ..
      INTRINSIC MAX, SQRT
C***FIRST EXECUTABLE STATEMENT  SORTH
C
C         Get norm of unaltered VNEW for later use.
C
      VNRM = SNRM2(N, VNEW, 1)
C   -------------------------------------------------------------------
C         Perform the modified Gram-Schmidt procedure on VNEW =A*V(LL).
C         Scaled inner products give new column of HES.
C         Projections of earlier vectors are subtracted from VNEW.
C   -------------------------------------------------------------------
      I0 = MAX(1,LL-KMP+1)
      DO 10 I = I0,LL
         HES(I,LL) = SDOT(N, V(1,I), 1, VNEW, 1)
         TEM = -HES(I,LL)
         CALL SAXPY(N, TEM, V(1,I), 1, VNEW, 1)
 10   CONTINUE
C   -------------------------------------------------------------------
C         Compute SNORMW = norm of VNEW.  If VNEW is small compared
C         to its input value (in norm), then reorthogonalize VNEW to
C         V(*,1) through V(*,LL).  Correct if relative correction
C         exceeds 1000*(unit roundoff).  Finally, correct SNORMW using
C         the dot products involved.
C   -------------------------------------------------------------------
      SNORMW = SNRM2(N, VNEW, 1)
      IF (VNRM + 0.001E0*SNORMW .NE. VNRM) RETURN
      SUMDSQ = 0
      DO 30 I = I0,LL
         TEM = -SDOT(N, V(1,I), 1, VNEW, 1)
         IF (HES(I,LL) + 0.001E0*TEM .EQ. HES(I,LL)) GO TO 30
         HES(I,LL) = HES(I,LL) - TEM
         CALL SAXPY(N, TEM, V(1,I), 1, VNEW, 1)
         SUMDSQ = SUMDSQ + TEM**2
 30   CONTINUE
      IF (SUMDSQ .EQ. 0.0E0) RETURN
      ARG = MAX(0.0E0,SNORMW**2 - SUMDSQ)
      SNORMW = SQRT(ARG)
C
      RETURN
C------------- LAST LINE OF SORTH FOLLOWS ----------------------------
      END
*DECK SOS
      SUBROUTINE SOS (FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, RW, LRW,
     +   IW, LIW)
C***BEGIN PROLOGUE  SOS
C***PURPOSE  Solve a square system of nonlinear equations.
C***LIBRARY   SLATEC
C***CATEGORY  F2A
C***TYPE      SINGLE PRECISION (SOS-S, DSOS-D)
C***KEYWORDS  BROWN'S METHOD, NEWTON'S METHOD, NONLINEAR EQUATIONS,
C             ROOTS, SOLUTIONS
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     SOS solves a system of NEQ simultaneous nonlinear equations in
C     NEQ unknowns.  That is, it solves the problem   F(X)=0
C     where X is a vector with components  X(1),...,X(NEQ)  and  F
C     is a vector of nonlinear functions.  Each equation is of the form
C
C               F (X(1),...,X(NEQ))=0     for K=1,...,NEQ.
C                K
C
C     The algorithm is based on an iterative method which is a
C     variation of Newton's method using Gaussian elimination
C     in a manner similar to the Gauss-Seidel process.  Convergence
C     is roughly quadratic.  All partial derivatives required by
C     the algorithm are approximated by first difference quotients.
C     The convergence behavior of this code is affected by the
C     ordering of the equations, and it is advantageous to place linear
C     and mildly nonlinear equations first in the ordering.
C
C     Actually, SOS is merely an interfacing routine for
C     calling subroutine SOSEQS which embodies the solution
C     algorithm.  The purpose of this is to add greater
C     flexibility and ease of use for the prospective user.
C
C     SOSEQS calls the accompanying routine SOSSOL, which solves special
C     triangular linear systems by back-substitution.
C
C     The user must supply a function subprogram which evaluates the
C     K-th equation only (K specified by SOSEQS) for each call
C     to the subprogram.
C
C     SOS represents an implementation of the mathematical algorithm
C     described in the references below.  It is a modification of the
C     code SOSNLE written by H. A. Watts in 1973.
C
C **********************************************************************
C   -Input-
C
C     FNC -Name of the function program which evaluates the equations.
C          This name must be in an EXTERNAL statement in the calling
C          program.  The user must supply FNC in the form FNC(X,K),
C          where X is the solution vector (which must be dimensioned
C          in FNC) and FNC returns the value of the K-th function.
C
C     NEQ -Number of equations to be solved.
C
C     X   -Solution vector.  Initial guesses must be supplied.
C
C     RTOLX -Relative error tolerance used in the convergence criteria.
C          Each solution component X(I) is checked by an accuracy test
C          of the form   ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX,
C          where XOLD(I) represents the previous iteration value.
C          RTOLX must be non-negative.
C
C     ATOLX -Absolute error tolerance used in the convergence criteria.
C          ATOLX must be non-negative.  If the user suspects some
C          solution component may be zero, he should set ATOLX to an
C          appropriate (depends on the scale of the remaining variables)
C          positive value for better efficiency.
C
C     TOLF -Residual error tolerance used in the convergence criteria.
C          Convergence will be indicated if all residuals (values of the
C          functions or equations) are not bigger than TOLF in
C          magnitude.  Note that extreme care must be given in assigning
C          an appropriate value for TOLF because this convergence test
C          is dependent on the scaling of the equations.  An
C          inappropriate value can cause premature termination of the
C          iteration process.
C
C     IFLAG -Optional input indicator.  You must set  IFLAG=-1  if you
C          want to use any of the optional input items listed below.
C          Otherwise set it to zero.
C
C     RW  -A REAL work array which is split apart by SOS and used
C          internally by SOSEQS.
C
C     LRW -Dimension of the RW array.  LRW must be at least
C                    1 + 6*NEQ + NEQ*(NEQ+1)/2
C
C     IW  -An INTEGER work array which is split apart by SOS and used
C          internally by SOSEQS.
C
C     LIW -Dimension of the IW array. LIW must be at least  3 + NEQ.
C
C   -Optional Input-
C
C     IW(1) -Internal printing parameter.  You must set  IW(1)=-1  if
C          you want the intermediate solution iterates to be printed.
C
C     IW(2) -Iteration limit.  The maximum number of allowable
C          iterations can be specified, if desired.  To override the
C          default value of 50, set IW(2) to the number wanted.
C
C     Remember, if you tell the code that you are using one of the
C               options (by setting IFLAG=-1), you must supply values
C               for both IW(1) and IW(2).
C
C **********************************************************************
C   -Output-
C
C     X   -Solution vector.
C
C     IFLAG -Status indicator
C
C                         *** Convergence to a Solution ***
C
C          1 Means satisfactory convergence to a solution was achieved.
C            Each solution component X(I) satisfies the error tolerance
C            test   ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX.
C
C          2 Means procedure converged to a solution such that all
C            residuals are at most TOLF in magnitude,
C            ABS(FNC(X,I)) .LE. TOLF.
C
C          3 Means that conditions for both IFLAG=1 and IFLAG=2 hold.
C
C          4 Means possible numerical convergence.  Behavior indicates
C            limiting precision calculations as a result of user asking
C            for too much accuracy or else convergence is very slow.
C            Residual norms and solution increment norms have
C            remained roughly constant over several consecutive
C            iterations.
C
C                         *** Task Interrupted ***
C
C          5 Means the allowable number of iterations has been met
C            without obtaining a solution to the specified accuracy.
C            Very slow convergence may be indicated.  Examine the
C            approximate solution returned and see if the error
C            tolerances seem appropriate.
C
C          6 Means the allowable number of iterations has been met and
C            the iterative process does not appear to be converging.
C            A local minimum may have been encountered or there may be
C            limiting precision difficulties.
C
C          7 Means that the iterative scheme appears to be diverging.
C            Residual norms and solution increment norms have
C            increased over several consecutive iterations.
C
C                         *** Task Cannot Be Continued ***
C
C          8 Means that a Jacobian-related matrix was singular.
C
C          9 Means improper input parameters.
C
C          *** IFLAG should be examined after each call to   ***
C          *** SOS with the appropriate action being taken.  ***
C
C
C     RW(1) -Contains a norm of the residual.
C
C     IW(3) -Contains the number of iterations used by the process.
C
C **********************************************************************
C***REFERENCES  K. M. Brown, Solution of simultaneous nonlinear
C                 equations, Algorithm 316, Communications of the
C                 A.C.M. 10, (1967), pp. 728-729.
C               K. M. Brown, A quadratically convergent Newton-like
C                 method based upon Gaussian elimination, SIAM Journal
C                 on Numerical Analysis 6, (1969), pp. 560-569.
C***ROUTINES CALLED  SOSEQS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls, changed Prologue
C           comments to agree with DSOS.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SOS
      DIMENSION X(*), RW(*), IW(*)
      CHARACTER*8 XERN1
      CHARACTER*16 XERN3, XERN4
      EXTERNAL FNC
C***FIRST EXECUTABLE STATEMENT  SOS
      INPFLG = IFLAG
C
C     CHECK FOR VALID INPUT
C
      IF (NEQ .LE. 0) THEN
         WRITE (XERN1, '(I8)') NEQ
         CALL XERMSG ('SLATEC', 'SOS', 'THE NUMBER OF EQUATIONS ' //
     *      'MUST BE A POSITIVE INTEGER.  YOU HAVE CALLED THE ' //
     *      'CODE WITH NEQ = ' // XERN1, 1, 1)
         IFLAG = 9
      ENDIF
C
      IF (RTOLX .LT. 0.0D0 .OR. ATOLX .LT. 0.0D0) THEN
         WRITE (XERN3, '(1PE15.6)') ATOLX
         WRITE (XERN4, '(1PE15.6)') RTOLX
         CALL XERMSG ('SLATEC', 'SOS', 'THE ERROR TOLERANCES FOR ' //
     *      'THE SOLUTION ITERATES CANNOT BE NEGATIVE. YOU HAVE ' //
     *      'CALLED THE CODE WITH  RTOLX = ' // XERN3 //
     *      ' AND ATOLX = ' // XERN4,2, 1)
            IFLAG = 9
      ENDIF
C
      IF (TOLF .LT. 0.0D0) THEN
         WRITE (XERN3, '(1PE15.6)') TOLF
         CALL XERMSG ('SLATEC', 'SOS', 'THE RESIDUAL ERROR ' //
     *      'TOLERANCE MUST BE NON-NEGATIVE.  YOU HAVE CALLED THE ' //
     *      'CODE WITH TOLF = ' // XERN3, 3, 1)
            IFLAG = 9
      ENDIF
C
      IPRINT = 0
      MXIT = 50
      IF (INPFLG .EQ. (-1)) THEN
         IF (IW(1) .EQ. (-1)) IPRINT = -1
         MXIT = IW(2)
         IF (MXIT .LE. 0) THEN
            WRITE (XERN1, '(I8)') MXIT
            CALL XERMSG ('SLATEC', 'SOS', 'YOU HAVE TOLD THE CODE ' //
     *         'TO USE OPTIONAL IN PUT ITEMS BY SETTING  IFLAG=-1. '//
     *         'HOWEVER YOU HAVE CALLED THE CODE WITH THE MAXIMUM ' //
     *         'ALLOWABLE NUMBER OF ITERATIONS SET TO  IW(2) = ' //
     *         XERN1, 4, 1)
            IFLAG = 9
         ENDIF
      ENDIF
C
      NC = (NEQ*(NEQ+1))/2
      IF (LRW .LT. 1 + 6*NEQ + NC) THEN
         WRITE (XERN1, '(I8)') LRW
         CALL XERMSG ('SLATEC', 'SOS', 'DIMENSION OF THE RW ARRAY ' //
     *      'MUST BE AT LEAST 1 + 6*NEQ + NEQ*(NEQ+1)/2 .  YOU HAVE ' //
     *      'CALLED THE CODE WITH LRW = ' // XERN1, 5, 1)
         IFLAG = 9
      ENDIF
C
      IF (LIW .LT. 3 + NEQ) THEN
         WRITE (XERN1, '(I8)') LIW
         CALL XERMSG ('SLATEC', 'SOS', 'DIMENSION OF THE IW ARRAY ' //
     *      'MUST BE AT LEAST   3 + NEQ.  YOU HAVE CALLED THE CODE ' //
     *      'WITH  LIW = ' // XERN1, 6, 1)
         IFLAG = 9
      ENDIF
C
      IF (IFLAG .NE. 9) THEN
         NCJS = 6
         NSRRC = 4
         NSRI = 5
C
         K1 = NC + 2
         K2 = K1 + NEQ
         K3 = K2 + NEQ
         K4 = K3 + NEQ
         K5 = K4 + NEQ
         K6 = K5 + NEQ
C
         CALL SOSEQS(FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, MXIT, NCJS,
     1               NSRRC, NSRI, IPRINT, RW(1), RW(2), NC, RW(K1),
     2               RW(K2), RW(K3), RW(K4), RW(K5), RW(K6), IW(4))
C
         IW(3) = MXIT
      ENDIF
      RETURN
      END
*DECK SOSEQS
      SUBROUTINE SOSEQS (FNC, N, S, RTOLX, ATOLX, TOLF, IFLAG, MXIT,
     +   NCJS, NSRRC, NSRI, IPRINT, FMAX, C, NC, B, P, TEMP, X, Y, FAC,
     +   IS)
C***BEGIN PROLOGUE  SOSEQS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SOS
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SOSEQS-S, DSOSEQ-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     SOSEQS solves a system of N simultaneous nonlinear equations.
C     See the comments in the interfacing routine SOS for a more
C     detailed description of some of the items in the calling list.
C
C ********************************************************************
C
C   -INPUT-
C     FNC -Function subprogram which evaluates the equations
C     N   -Number of equations
C     S   -Solution vector of initial guesses
C     RTOLX-Relative error tolerance on solution components
C     ATOLX-Absolute error tolerance on solution components
C     TOLF-Residual error tolerance
C     MXIT-Maximum number of allowable iterations.
C     NCJS-Maximum number of consecutive iterative steps to perform
C          using the same triangular Jacobian matrix approximation.
C     NSRRC-Number of consecutive iterative steps for which the
C          limiting precision accuracy test must be satisfied
C          before the routine exits with IFLAG=4.
C     NSRI-Number of consecutive iterative steps for which the
C          diverging condition test must be satisfied before
C          the routine exits with IFLAG=7.
C     IPRINT-Internal printing parameter.  You must set IPRINT=-1 if you
C          want the intermediate solution iterates and a residual norm
C          to be printed.
C     C   -Internal work array, dimensioned at least N*(N+1)/2.
C     NC  -Dimension of C array. NC  .GE.  N*(N+1)/2.
C     B   -Internal work array, dimensioned N.
C     P   -Internal work array, dimensioned N.
C     TEMP-Internal work array, dimensioned N.
C     X   -Internal work array, dimensioned N.
C     Y   -Internal work array, dimensioned N.
C     FAC -Internal work array, dimensioned N.
C     IS  -Internal work array, dimensioned N.
C
C   -OUTPUT-
C     S   -Solution vector
C     IFLAG-Status indicator flag
C     MXIT-The actual number of iterations performed
C     FMAX-Residual norm
C     C   -Upper unit triangular matrix which approximates the
C          forward triangularization of the full Jacobian matrix.
C          stored in a vector with dimension at least N*(N+1)/2.
C     B   -Contains the residuals (function values) divided
C          by the corresponding components of the P vector
C     P   -Array used to store the partial derivatives. After
C          each iteration P(K) contains the maximal derivative
C          occurring in the K-th reduced equation.
C     TEMP-Array used to store the previous solution iterate.
C     X   -Solution vector. Contains the values achieved on the
C          last iteration loop upon exit from SOS.
C     Y   -Array containing the solution increments.
C     FAC -Array containing factors used in computing numerical
C          derivatives.
C     IS  -Records the pivotal information (column interchanges)
C
C **********************************************************************
C *** Three machine dependent parameters appear in this subroutine.
C
C *** The smallest positive magnitude, zero, is defined by the function
C *** routine R1MACH(1).
C
C *** URO, The computer unit roundoff value, is defined by R1MACH(3) for
C *** machines that round or R1MACH(4) for machines that truncate.
C *** URO is the smallest positive number such that 1.+URO  .GT.  1.
C
C *** The output tape unit number, LOUN, is defined by the function
C *** I1MACH(2).
C **********************************************************************
C
C***SEE ALSO  SOS
C***ROUTINES CALLED  I1MACH, R1MACH, SOSSOL
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  SOSEQS
C
C
      DIMENSION S(*), C(NC), B(*), IS(*), P(*), TEMP(*), X(*), Y(*),
     1          FAC(*)
C
C***FIRST EXECUTABLE STATEMENT  SOSEQS
      URO = R1MACH(4)
      LOUN = I1MACH(2)
      ZERO = R1MACH(1)
      RE = MAX(RTOLX,URO)
      SRURO = SQRT(URO)
C
      IFLAG = 0
      NP1 = N + 1
      ICR = 0
      IC = 0
      ITRY = NCJS
      YN1 = 0.
      YN2 = 0.
      YN3 = 0.
      YNS = 0.
      MIT = 0
      FN1 = 0.
      FN2 = 0.
      FMXS = 0.
C
C     INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND
C     SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE.
C
      DO 10 K=1,N
        IS(K) = K
        X(K) = S(K)
        TEMP(K) = X(K)
   10 CONTINUE
C
C
C    *****************************************
C    **** BEGIN PRINCIPAL ITERATION LOOP  ****
C    *****************************************
C
      DO 330 M=1,MXIT
C
        DO 20 K=1,N
          FAC(K) = SRURO
   20   CONTINUE
C
   30   KN = 1
        FMAX = 0.
C
C
C    ******** BEGIN SUBITERATION LOOP DEFINING THE LINEARIZATION OF EACH
C    ******** EQUATION WHICH RESULTS IN THE CONSTRUCTION OF AN UPPER
C    ******** TRIANGULAR MATRIX APPROXIMATING THE FORWARD
C    ******** TRIANGULARIZATION OF THE FULL JACOBIAN MATRIX
C
        DO 170 K=1,N
          KM1 = K - 1
C
C     BACK-SOLVE A TRIANGULAR LINEAR SYSTEM OBTAINING
C     IMPROVED SOLUTION VALUES FOR K-1 OF THE VARIABLES
C     FROM THE FIRST K-1 EQUATIONS. THESE VARIABLES ARE THEN
C     ELIMINATED FROM THE K-TH EQUATION.
C
          IF (KM1 .EQ. 0) GO TO 50
          CALL SOSSOL(K, N, KM1, Y, C, B, KN)
          DO 40 J=1,KM1
            JS = IS(J)
            X(JS) = TEMP(JS) + Y(J)
   40     CONTINUE
C
C
C     EVALUATE THE K-TH EQUATION AND THE INTERMEDIATE COMPUTATION
C     FOR THE MAX NORM OF THE RESIDUAL VECTOR.
C
   50     F = FNC(X,K)
          FMAX = MAX(FMAX,ABS(F))
C
C     IF WE WISH TO PERFORM SEVERAL ITERATIONS USING A FIXED
C     FACTORIZATION OF AN APPROXIMATE JACOBIAN,WE NEED ONLY
C     UPDATE THE CONSTANT VECTOR.
C
          IF (ITRY .LT. NCJS) GO TO 160
C
C
          IT = 0
C
C     COMPUTE PARTIAL DERIVATIVES THAT ARE REQUIRED IN THE LINEARIZATION
C     OF THE K-TH REDUCED EQUATION
C
          DO 90 J=K,N
            ITEM = IS(J)
            HX = X(ITEM)
            H = FAC(ITEM)*HX
            IF (ABS(H) .LE. ZERO) H = FAC(ITEM)
            X(ITEM) = HX + H
            IF (KM1 .EQ. 0) GO TO 70
            Y(J) = H
            CALL SOSSOL(K, N, J, Y, C, B, KN)
            DO 60 L=1,KM1
              LS = IS(L)
              X(LS) = TEMP(LS) + Y(L)
   60       CONTINUE
   70       FP = FNC(X,K)
            X(ITEM) = HX
            FDIF = FP - F
            IF (ABS(FDIF) .GT. URO*ABS(F)) GO TO 80
            FDIF = 0.
            IT = IT + 1
   80       P(J) = FDIF/H
   90     CONTINUE
C
          IF (IT .LE. (N-K)) GO TO 110
C
C     ALL COMPUTED PARTIAL DERIVATIVES OF THE K-TH EQUATION
C     ARE EFFECTIVELY ZERO.TRY LARGER PERTURBATIONS OF THE
C     INDEPENDENT VARIABLES.
C
          DO 100 J=K,N
            ISJ = IS(J)
            FACT = 100.*FAC(ISJ)
            IF (FACT .GT. 1.E+10) GO TO 340
            FAC(ISJ) = FACT
  100     CONTINUE
          GO TO 30
C
  110     IF (K .EQ. N) GO TO 160
C
C     ACHIEVE A PIVOTING EFFECT BY CHOOSING THE MAXIMAL DERIVATIVE
C     ELEMENT
C
          PMAX = 0.
          DO 120 J=K,N
            TEST = ABS(P(J))
            IF (TEST .LE. PMAX) GO TO 120
            PMAX = TEST
            ISV = J
  120     CONTINUE
          IF (PMAX .EQ. 0.) GO TO 340
C
C     SET UP THE COEFFICIENTS FOR THE K-TH ROW OF THE TRIANGULAR
C     LINEAR SYSTEM AND SAVE THE PARTIAL DERIVATIVE OF
C     LARGEST MAGNITUDE
C
          PMAX = P(ISV)
          KK = KN
          DO 140 J=K,N
            IF (J .EQ. ISV) GO TO 130
            C(KK) = -P(J)/PMAX
  130       KK = KK + 1
  140     CONTINUE
          P(K) = PMAX
C
C
          IF (ISV .EQ. K) GO TO 160
C
C     INTERCHANGE THE TWO COLUMNS OF C DETERMINED BY THE
C     PIVOTAL STRATEGY
C
          KSV = IS(K)
          IS(K) = IS(ISV)
          IS(ISV) = KSV
C
          KD = ISV - K
          KJ = K
          DO 150 J=1,K
            CSV = C(KJ)
            JK = KJ + KD
            C(KJ) = C(JK)
            C(JK) = CSV
            KJ = KJ + N - J
  150     CONTINUE
C
  160     KN = KN + NP1 - K
C
C     STORE THE COMPONENTS FOR THE CONSTANT VECTOR
C
          B(K) = -F/P(K)
C
  170   CONTINUE
C
C    ********
C    ******** END OF LOOP CREATING THE TRIANGULAR LINEARIZATION MATRIX
C    ********
C
C
C     SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW SOLUTION
C     APPROXIMATION AND OBTAIN THE SOLUTION INCREMENT NORM.
C
        KN = KN - 1
        Y(N) = B(N)
        IF (N .GT. 1) CALL SOSSOL(N, N, N, Y, C, B, KN)
        XNORM = 0.
        YNORM = 0.
        DO 180 J=1,N
          YJ = Y(J)
          YNORM = MAX(YNORM,ABS(YJ))
          JS = IS(J)
          X(JS) = TEMP(JS) + YJ
          XNORM = MAX(XNORM,ABS(X(JS)))
  180   CONTINUE
C
C
C     PRINT INTERMEDIATE SOLUTION ITERATES AND RESIDUAL NORM IF DESIRED
C
        IF (IPRINT.NE.(-1)) GO TO 190
        MM = M - 1
        WRITE (LOUN,1234) FMAX, MM, (X(J),J=1,N)
 1234   FORMAT ('0RESIDUAL NORM =', E9.2, /1X, 'SOLUTION ITERATE',
     1   ' (', I3, ')', /(1X, 5E26.14))
  190   CONTINUE
C
C     TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE AND/OR ABSOLUTE ERROR
C     COMPARISON ON SUCCESSIVE APPROXIMATIONS OF EACH SOLUTION VARIABLE)
C
        DO 200 J=1,N
          JS = IS(J)
          IF (ABS(Y(J)) .GT. RE*ABS(X(JS))+ATOLX) GO TO 210
  200   CONTINUE
        IF (FMAX .LE. FMXS) IFLAG = 1
C
C     TEST FOR CONVERGENCE TO A SOLUTION BASED ON RESIDUALS
C
  210   IF (FMAX .GT. TOLF) GO TO 220
        IFLAG = IFLAG + 2
  220   IF (IFLAG .GT. 0) GO TO 360
C
C
        IF (M .GT. 1) GO TO 230
        FMIN = FMAX
        GO TO 280
C
C     SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM.
C
  230   IF (FMAX .GE. FMIN) GO TO 250
        MIT = M + 1
        YN1 = YNORM
        YN2 = YNS
        FN1 = FMXS
        FMIN = FMAX
        DO 240 J=1,N
          S(J) = X(J)
  240   CONTINUE
        IC = 0
C
C     TEST FOR LIMITING PRECISION CONVERGENCE.  VERY SLOWLY CONVERGENT
C     PROBLEMS MAY ALSO BE DETECTED.
C
  250   IF (YNORM .GT. SRURO*XNORM) GO TO 260
        IF ((FMAX .LT. 0.2*FMXS) .OR. (FMAX .GT. 5.*FMXS)) GO TO 260
        IF ((YNORM .LT. 0.2*YNS) .OR. (YNORM .GT. 5.*YNS)) GO TO 260
        ICR = ICR + 1
        IF (ICR .LT. NSRRC) GO TO 270
        IFLAG = 4
        FMAX = FMIN
        GO TO 380
  260   ICR = 0
C
C     TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME.
C
        IF ((YNORM .LE. 2.*YNS) .AND. (FMAX .LE. 2.*FMXS)) GO TO 270
        IC = IC + 1
        IF (IC .LT. NSRI) GO TO 280
        IFLAG = 7
        GO TO 360
  270   IC = 0
C
C     CHECK TO SEE IF NEXT ITERATION CAN USE THE OLD JACOBIAN
C     FACTORIZATION
C
  280   ITRY = ITRY - 1
        IF (ITRY .EQ. 0) GO TO 290
        IF (20.*YNORM .GT. XNORM) GO TO 290
        IF (YNORM .GT. 2.*YNS) GO TO 290
        IF (FMAX .LT. 2.*FMXS) GO TO 300
  290   ITRY = NCJS
C
C     SAVE THE CURRENT SOLUTION APPROXIMATION AND THE RESIDUAL AND
C     SOLUTION INCREMENT NORMS FOR USE IN THE NEXT ITERATION.
C
  300   DO 310 J=1,N
          TEMP(J) = X(J)
  310   CONTINUE
        IF (M.NE.MIT) GO TO 320
        FN2 = FMAX
        YN3 = YNORM
  320   FMXS = FMAX
        YNS = YNORM
C
C
  330 CONTINUE
C
C    *****************************************
C    **** END OF PRINCIPAL ITERATION LOOP ****
C    *****************************************
C
C
C     TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED.
      M = MXIT
      IFLAG = 5
      IF (YN1 .GT. 10.0*YN2 .OR. YN3 .GT. 10.0*YN1) IFLAG = 6
      IF (FN1 .GT. 5.0*FMIN .OR. FN2 .GT. 5.0*FMIN) IFLAG = 6
      IF (FMAX .GT. 5.0*FMIN) IFLAG = 6
      GO TO 360
C
C
C     A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR.
  340 IFLAG = 8
      DO 350 J=1,N
        S(J) = TEMP(J)
  350 CONTINUE
      GO TO 380
C
C
  360 DO 370 J=1,N
        S(J) = X(J)
  370 CONTINUE
C
C
  380 MXIT = M
      RETURN
      END
*DECK SOSSOL
      SUBROUTINE SOSSOL (K, N, L, X, C, B, M)
C***BEGIN PROLOGUE  SOSSOL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SOS
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SOSSOL-S, DSOSSL-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     SOSSOL solves an upper triangular type of linear system by back
C     substitution.
C
C     The matrix C is upper trapezoidal and stored as a linear array by
C     rows. The equations have been normalized so that the diagonal
C     entries of C are understood to be unity. The off diagonal entries
C     and the elements of the constant right hand side vector B have
C     already been stored as the negatives of the corresponding equation
C     values.
C     with each call to SOSSOL a (K-1) by (K-1) triangular system is
C     resolved. For L greater than K, column L of C is included in the
C     right hand side vector.
C
C***SEE ALSO  SOS
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  SOSSOL
C
C
      DIMENSION X(*), C(*), B(*)
C
C***FIRST EXECUTABLE STATEMENT  SOSSOL
      NP1 = N + 1
      KM1 = K - 1
      LK = KM1
      IF (L .EQ. K) LK = K
      KN = M
C
C
      DO 40 KJ=1,KM1
        KMM1 = K - KJ
        KM = KMM1 + 1
        XMAX = 0.
        KN = KN - NP1 + KMM1
        IF (KM .GT. LK) GO TO 20
        JKM = KN
C
        DO 10 J=KM,LK
          JKM = JKM + 1
          XMAX = XMAX + C(JKM)*X(J)
   10   CONTINUE
C
   20   IF (L .LE. K) GO TO 30
        JKM = KN + L - KMM1
        XMAX = XMAX + C(JKM)*X(L)
   30   X(KMM1) = XMAX + B(KMM1)
   40 CONTINUE
C
      RETURN
      END
