C     ALGORITHM 573, COLLECTED ALGORITHMS FROM ACM. THIS WORK
C     PUBLISHED IN TRANS. MATH. SOFTWARE, 7(3), PP. 369-383.
C  ALGORITHM 573
C
C  NL2SOL -- AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM
C
C  AUTHORS = JOHN E. DENNIS, JR., DAVID M. GAY, AND ROY E. WELSCH
C
C  ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, SEPTEMBER, 1981.
C
C  THIS FILE COMES IN 9 SECTIONS, SEPARATED BY A COMMENT LINE HAVING C
C  IN COLUMN 1 AND SLASHES IN COLUMNS 2-72.  THE FIRST SECTION CON-
C  SISTS OF THESE COMMENTS.  SECTIONS 2-5 CONTAIN SINGLE-PRECISION 1966
C  ANSI STANDARD FORTRAN SOURCE CODE, AND SECTIONS 6-9 ARE DOUBLE-
C  PRECISION VERSIONS OF SECTIONS 2-5.  COMMENTS IN SECTIONS 4 AND 8
C  DESCRIBE AN EASY WAY TO MODIFY THIS CODE FOR USE WITH FORTRAN 77.
C  THE 9 SECTIONS ARE AS FOLLOWS...
C
C     1. THESE COMMENTS.
C     2. SINGLE-PREC. SHORT TEST PROGRAM.
C     3. SINGLE-PREC. MACHINE-DEPENDENT FUNCTIONS IMDCON AND RMDCON.
C     4. SINGLE-PREC. MACHINE-INDEPENDENT NL2SOL MODULES.
C     5. SINGLE-PREC. LONG TEST PROGRAM.
C     6. DOUBLE-PREC. SHORT TEST PROGRAM.
C     7. DOUBLE-PREC. MACHINE-DEPENDENT FUNCTIONS IMDCON AND RMDCON.
C     8. DOUBLE-PREC. MACHINE-INDEPENDENT NL2SOL MODULES.
C     9. DOUBLE-PREC. LONG TEST PROGRAM.
C
C  THE SHORT TEST PROGRAM (SECTIONS 2 AND 6) AMOUNTS TO THE EXAMPLE IN
C  SECTION 3.2 OF THE DESCRIPTION OF TOMS ALGORITHM 573 WITH AN ADDED
C  CALL ON NL2SNO.
C
C  DEPENDING ON THE COMPUTER USED, IT MAY BE NECESSARY TO CHANGE THE
C  DATA STATEMENTS IN SECTIONS 3 AND 7 -- SEE SECTION 3.12 OF THE
C  DESCRIPTION OF TOMS ALGORITHM 573.  (THE VERSION OF RMDCON IN
C  SECTION 3 IS SET FOR CDC COMPUTERS, AND THAT IN SECTION 8 IS SET FOR
C  IBM 360 AND 370 COMPUTERS.)
C
C  THE FIRST THREE MODULES IN SECTIONS 4 AND 8 ARE NL2SOL, NL2SNO, AND
C  NL2ITR.  THE REMAINING MODULES FOLLOW IN ALPHABETICAL ORDER.
C
C  THE LONG TEST PROGRAM (SECTIONS 5 AND 9) RUNS THE TESTS REPORTED IN
C  TABLE II OF THE TOMS PAPER ON NL2SOL.  THIS PROGRAM PRODUCES A
C  ONE-PAGE SUMMARY ON UNIT IMDCON(2) AND DETAILED OUTPUT ON UNIT
C  IMDCON(1).  THE LATTER MAY BE SUPPRESSED BY ARRANGING FOR IMDCON(1)
C  TO RETURN 0.
C
C///////////////////////////////////////////////////////////////////////
      END
C     ***  TEST NL2SOL AND NL2SNO ON MADSEN EXAMPLE  ***                MAD00010
      INTEGER IV(62), UIPARM(1)
      REAL V(147), X(2), URPARM(1)
      EXTERNAL MADR, MADJ
      X(1) = 3.0
      X(2) = 1.0
      IV(1) = 0
      CALL NL2SOL(3, 2, X, MADR, MADJ, IV, V, UIPARM, URPARM, MADR)
      IV(1) = 12
      X(1) = 3.0
      X(2) = 1.0
      CALL NL2SNO(3, 2, X, MADR, IV, V, UIPARM, URPARM, MADR)
      STOP
      END
      SUBROUTINE MADR(N, P, X, NF, R, UIPARM, URPARM, UFPARM)
      INTEGER N, P, NF, UIPARM(1)
      REAL X(P), R(N), URPARM(1)
      EXTERNAL UFPARM
      R(1) = X(1)**2 + X(2)**2 + X(1)*X(2)
      R(2) = SIN(X(1))
      R(3) = COS(X(2))
      RETURN
      END
      SUBROUTINE MADJ(N, P, X, NF, J, UIPARM, URPARM, UFPARM)
      INTEGER N, P, NF, UIPARM(1)
      REAL X(P), J(N,P), URPARM(1)
      EXTERNAL UFPARM
      J(1,1) = 2.0*X(1) + X(2)
      J(1,2) = 2.0*X(2) + X(1)
      J(2,1) = COS(X(1))
      J(2,2) = 0.0
      J(3,1) = 0.0
      J(3,2) = -SIN(X(2))
      RETURN
      END
      INTEGER FUNCTION IMDCON(K)                                        IMD00010
C
      INTEGER K
C
C  ***  RETURN INTEGER MACHINE-DEPENDENT CONSTANTS  ***
C
C     ***  K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER.   ***
C     ***  K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER.  ***
C     ***  K = 3 MEANS RETURN  INPUT UNIT NUMBER.            ***
C          (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.)
C
      INTEGER MDCON(3)
      DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/
C
      IMDCON = MDCON(K)
      RETURN
C  ***  LAST CARD OF IMDCON FOLLOWS  ***
      END
      REAL FUNCTION RMDCON(K)                                           RMD00010
C
C  ***  RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL  ***
C
C +++  COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES.  +++
C +++  TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE   +++
C +++  DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++
C +++  AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S)  +++
C +++  THAT CORRESPOND TO THE NEW MACHINE.                           +++
C
      INTEGER K
C
C  ***  THE CONSTANT RETURNED DEPENDS ON K...
C
C  ***        K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS.
C  ***        K = 2... SQUARE ROOT OF 1.001*ETA.
C  ***        K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH
C  ***                 THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1.
C  ***        K = 4... SQUARE ROOT OF 0.999*MACHEP.
C  ***        K = 5... SQUARE ROOT OF 0.999*BIG (SEE K = 6).
C  ***        K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS.
C
      REAL BIG, ETA, MACHEP
C/+
      REAL SQRT
C/
      REAL ONE001, PT999
C
      DATA ONE001/1.001/, PT999/0.999/
C
C  +++  IBM 360, IBM 370, OR XEROX  +++
C
C     DATA BIG/Z7FFFFFFF/, ETA/Z00100000/, MACHEP/Z3C100000/
C
C  +++  DATA GENERAL  +++
C
C     DATA BIG/0.7237E+76/, ETA/0.5398E-78/, MACHEP/0.9537E-06/
C
C  +++  DEC 11  +++
C
C     DATA BIG/1.7E+38/, ETA/2.9388E-39/, MACHEP/1.1921E-07/
C
C  +++  HP3000  +++
C
C     DATA BIG/1.1579E+77/, ETA/8.6362E-78/, MACHEP/2.3842E-07/
C
C  +++  HONEYWELL  +++
C
C     DATA BIG/O376777000000/, ETA/O404400400000/,
C    1     MACHEP/O716400000000/
C
C  +++  DEC10  +++
C
C     DATA BIG/"377777777777/, ETA/"000400000021/,
C    1     MACHEP/"147400000000/
C
C  +++  BURROUGHS  +++
C
C     DATA BIG/O0777777777777777/, ETA/O1771000000000000/,
C    1     MACHEP/O1301000000000000/
C
C  +++  CONTROL DATA  +++
C
      DATA BIG/37754000000000000000B/, ETA/00024000000000000000B/,
     1     MACHEP/16414000000000000000B/
C
C  +++  PRIME  +++
C
C     DATA BIG/1.7E+38/, ETA/1.47E-39/, MACHEP/2.38419E-7/
C
C  +++  UNIVAC  +++
C
C     DATA BIG/1.69E+38/, ETA/5.9E-39/, MACHEP/1.4901162E-8/
C
C  +++  VAX  +++
C
C     DATA BIG/1.7E+38/, ETA/2.939E-39/, MACHEP/5.9604645E-08/
C
C-------------------------------  BODY  --------------------------------
C
      GO TO (10, 20, 30, 40, 50, 60), K
C
 10   RMDCON = ETA
      GO TO 999
C
 20   RMDCON = SQRT(ONE001*ETA)
      GO TO 999
C
 30   RMDCON = MACHEP
      GO TO 999
C
 40   RMDCON = SQRT(PT999*MACHEP)
      GO TO 999
C
 50   RMDCON = SQRT(PT999*BIG)
      GO TO 999
C
 60   RMDCON = BIG
C
 999  RETURN
C  ***  LAST CARD OF RMDCON FOLLOWS  ***
      END
      SUBROUTINE NL2SOL(N, P, X, CALCR, CALCJ, IV, V, UIPARM, URPARM,   NL200010
     1                  UFPARM)
C
C  ***  MINIMIZE NONLINEAR SUM OF SQUARES USING ANALYTIC JACOBIAN  ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
      INTEGER N, P, IV(1), UIPARM(1)
      REAL X(P), V(1), URPARM(1)
C     DIMENSION IV(60+P),  V(93 + N*P + 3*N + P*(3*P+33)/2)
C     DIMENSION UIPARM(*), URPARM(*)
      EXTERNAL CALCR, CALCJ, UFPARM
C
C  ***  PURPOSE  ***
C
C        GIVEN A P-VECTOR X OF PARAMETERS, CALCR COMPUTES AN N-VECTOR
C     R = R(X) OF RESIDUALS CORRESPONDING TO X.  (R(X) PROBABLY ARISES
C     FROM A NONLINEAR MODEL INVOLVING P PARAMETERS AND N OBSERVATIONS.)
C     THIS ROUTINE INTERACTS WITH NL2ITR TO SEEK A PARAMETER VECTOR X
C     THAT MINIMIZES THE SUM OF THE SQUARES OF (THE COMPONENTS OF) R(X),
C     I.E., THAT MINIMIZES THE SUM-OF-SQUARES FUNCTION
C     F(X) = (R(X)**T) * R(X) / 2.  R(X) IS ASSUMED TO BE A TWICE CON-
C     TINUOUSLY DIFFERENTIABLE FUNCTION OF X.
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C N........ (INPUT) THE NUMBER OF OBSERVATIONS, I.E., THE NUMBER OF
C                  COMPONENTS IN R(X).  N MUST BE .GE. P.
C P........ (INPUT) THE NUMBER OF PARAMETERS (COMPONENTS IN X).  P MUST
C                  BE POSITIVE.
C X........ (INPUT/OUTPUT).  ON INPUT, X IS AN INITIAL GUESS AT THE
C                  DESIRED PARAMETER ESTIMATE.  ON OUTPUT, X CONTAINS
C                  THE BEST PARAMETER ESTIMATE FOUND.
C CALCR.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES R(X).  CALCR
C                  MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
C                  IT IS INVOKED BY
C                       CALL CALCR(N,P,X,NF,R,UIPARM,URPARM,UFPARM)
C                  WHEN CALCR IS CALLED, NF IS THE INVOCATION COUNT
C                  FOR CALCR.  IT IS INCLUDED FOR POSSIBLE USE WITH
C                  CALCJ.  IF X IS OUT OF BOUNDS (E.G. IF IT WOULD
C                  CAUSE OVERFLOW IN COMPUTING R(X)), THEN CALCR SHOULD
C                  SET NF TO 0.  THIS WILL CAUSE A SHORTER STEP TO BE
C                  ATTEMPTED.  THE OTHER PARAMETERS ARE AS DESCRIBED
C                  ABOVE AND BELOW.  CALCR SHOULD NOT CHANGE N, P, OR X.
C CALCJ.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES THE JACOBIAN
C                  MATRIX J OF R AT X, I.E., THE N BY P MATRIX WHOSE
C                  (I,K) ENTRY IS THE PARTIAL DERIVATIVE OF THE I-TH
C                  COMPONENT OF R WITH RESPECT TO X(K).  CALCJ MUST BE
C                  DECLARED EXTERNAL IN THE CALLING PROGRAM.  IT IS
C                  INVOKED BY
C                       CALL CALCJ(N,P,X,NF,J,UIPARM,URPARM,UFPARM)
C                  NF IS THE INVOCATION COUNT FOR CALCR AT THE TIME
C                  R(X) WAS EVALUATED.  THE X PASSED TO CALCJ IS
C                  USUALLY THE ONE PASSED TO CALCR ON EITHER ITS MOST
C                  RECENT INVOCATION OR THE ONE PRIOR TO IT.  IF CALCR
C                  SAVES INTERMEDIATE RESULTS FOR USE BY CALCJ, THEN IT
C                  IS POSSIBLE TO TELL FROM NF WHETHER THEY ARE VALID
C                  FOR THE CURRENT X (OR WHICH COPY IS VALID IF TWO
C                  COPIES ARE KEPT).  IF J CANNOT BE COMPUTED AT X,
C                  THEN CALCJ SHOULD SET NF TO 0.  IN THIS CASE, NL2SOL
C                  WILL RETURN WITH IV(1) = 15.  THE OTHER PARAMETERS
C                  TO CALCJ ARE AS DESCRIBED ABOVE AND BELOW.  CALCJ
C                  SHOULD NOT CHANGE N, P, OR X.
C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH AT LEAST
C                  60 + P THAT HELPS CONTROL THE NL2SOL ALGORITHM AND
C                  THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI-
C                  TIES.  OF PARTICULAR INTEREST ARE THE INITIALIZATION/
C                  RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL
C                  PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC-
C                  TION EVALUATIONS.  SEE THE SECTION ON IV INPUT
C                  VALUES BELOW.
C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH AT
C                  LEAST 93 + N*P + 3*N + P*(3*P+33)/2 THAT HELPS CON-
C                  TROL THE NL2SOL ALGORITHM AND THAT IS USED TO STORE
C                  VARIOUS INTERMEDIATE QUANTITIES.  OF PARTICULAR IN-
C                  TEREST ARE THE ENTRIES IN V THAT LIMIT THE LENGTH OF
C                  THE FIRST STEP ATTEMPTED (LMAX0), SPECIFY CONVER-
C                  GENCE TOLERANCES (AFCTOL, RFCTOL, XCTOL, XFTOL),
C                  AND HELP CHOOSE THE STEP SIZE USED IN COMPUTING THE
C                  COVARIANCE MATRIX (DELTA0).  SEE THE SECTION ON
C                  (SELECTED) V INPUT VALUES BELOW.
C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE
C                  TO CALCR AND CALCJ.
C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT
C                  CHANGE TO CALCR AND CALCJ.
C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT
C                  CHANGE TO CALCR AND CALCJ.
C
C  ***  IV INPUT VALUES (FROM SUBROUTINE DFAULT)  ***
C
C IV(1)...  ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 12......
C             0 AND 12 MEAN THIS IS A FRESH START.  0 MEANS THAT
C             DFAULT(IV, V) IS TO BE CALLED TO PROVIDE ALL DEFAULT
C             VALUES TO IV AND V.  12 (THE VALUE THAT DFAULT ASSIGNS TO
C             IV(1)) MEANS THE CALLER HAS ALREADY CALLED DFAULT(IV, V)
C             AND HAS POSSIBLY CHANGED SOME IV AND/OR V ENTRIES TO NON-
C             DEFAULT VALUES.  DEFAULT = 12.
C IV(COVPRT)... IV(14) = 1 MEANS PRINT A COVARIANCE MATRIX AT THE SOLU-
C             TION.  (THIS MATRIX IS COMPUTED JUST BEFORE A RETURN WITH
C             IV(1) = 3, 4, 5, 6.)
C             IV(COVPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(COVREQ)... IV(15) = NONZERO MEANS COMPUTE A COVARIANCE MATRIX
C             JUST BEFORE A RETURN WITH IV(1) = 3, 4, 5, 6.  IN
C             THIS CASE, AN APPROXIMATE COVARIANCE MATRIX IS OBTAINED
C             IN ONE OF SEVERAL WAYS.  LET K = ABS(IV(COVREQ)) AND LET
C             SCALE = 2*F(X)/MAX(1,N-P),  WHERE 2*F(X) IS THE RESIDUAL
C             SUM OF SQUARES.  IF K = 1 OR 2, THEN A FINITE-DIFFERENCE
C             HESSIAN APPROXIMATION H IS OBTAINED.  IF H IS POSITIVE
C             DEFINITE (OR, FOR K = 3, IF THE JACOBIAN MATRIX J AT X
C             IS NONSINGULAR), THEN ONE OF THE FOLLOWING IS COMPUTED...
C                  K = 1....  SCALE * H**-1 * (J**T * J) * H**-1.
C                  K = 2....  SCALE * H**-1.
C                  K = 3....  SCALE * (J**T * J)**-1.
C             (J**T IS THE TRANSPOSE OF J, WHILE **-1 MEANS INVERSE.)
C             IF IV(COVREQ) IS POSITIVE, THEN BOTH FUNCTION AND GRAD-
C             IENT VALUES (CALLS ON CALCR AND CALCJ) ARE USED IN COM-
C             PUTING H (WITH STEP SIZES DETERMINED USING V(DELTA0) --
C             SEE BELOW), WHILE IF IV(COVREQ) IS NEGATIVE, THEN ONLY
C             FUNCTION VALUES (CALLS ON CALCR) ARE USED (WITH STEP
C             SIZES DETERMINED USING V(DLTFDC) -- SEE BELOW).  IF
C             IV(COVREQ) = 0, THEN NO ATTEMPT IS MADE TO COMPUTE A CO-
C             VARIANCE MATRIX (UNLESS IV(COVPRT) = 1, IN WHICH CASE
C             IV(COVREQ) = 1 IS ASSUMED).  SEE IV(COVMAT) BELOW.
C             DEFAULT = 1.
C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D (SEE REF. 1) SHOULD
C             BE CHOSEN.  IV(DTYPE) .GE. 1 MEANS CHOOSE D AS DESCRIBED
C             BELOW WITH V(DFAC).  IV(DTYPE) .LE. 0 MEANS THE CALLER
C             HAS CHOSEN D AND HAS STORED IT IN V STARTING AT
C             V(94 + 2*N + P*(3*P + 31)/2).  DEFAULT = 1.
C IV(INITS).... IV(25) TELLS HOW THE S MATRIX (SEE REF. 1) SHOULD BE
C             INITIALIZED.  0 MEANS INITIALIZE S TO 0 (AND START WITH
C             THE GAUSS-NEWTON MODEL).  1 AND 2 MEAN THAT THE CALLER
C             HAS STORED THE LOWER TRIANGLE OF THE INITIAL S ROWWISE IN
C             V STARTING AT V(87+2*P).  IV(INITS) = 1 MEANS START WITH
C             THE GAUSS-NEWTON MODEL, WHILE IV(INITS) = 2 MEANS START
C             WITH THE AUGMENTED MODEL (SEE REF. 1).  DEFAULT = 0.
C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS
C             (CALLS ON CALCR, EXCLUDING THOSE USED TO COMPUTE THE CO-
C             VARIANCE MATRIX) ALLOWED.  IF THIS NUMBER DOES NOT SUF-
C             FICE, THEN NL2SOL RETURNS WITH IV(1) = 9.  DEFAULT = 200.
C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C             IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA-
C             TIONS (CALLS ON CALCJ, EXCLUDING THOSE USED TO COMPUTE
C             THE COVARIANCE MATRIX) TO IV(MXITER) + 1.  IF IV(MXITER)
C             ITERATIONS DO NOT SUFFICE, THEN NL2SOL RETURNS WITH
C             IV(1) = 10.  DEFAULT = 150.
C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM-
C             MARY LINES PRINTED (BY ITSMRY).  IV(OUTLEV) = 0 MEANS DO
C             NOT PRINT ANY SUMMARY LINES.  OTHERWISE, PRINT A SUMMARY
C             LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS.  IF IV(OUTLEV)
C             IS POSITIVE, THEN SUMMARY LINES OF LENGTH 117 (PLUS CARRI-
C             AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING...  THE
C             ITERATION AND FUNCTION EVALUATION COUNTS, CURRENT FUNC-
C             TION VALUE (V(F) = HALF THE SUM OF SQUARES), RELATIVE
C             DIFFERENCE IN FUNCTION VALUES ACHIEVED BY THE LATEST STEP
C             (I.E., RELDF = (F0-V(F))/F0, WHERE F0 IS THE FUNCTION
C             VALUE FROM THE PREVIOUS ITERATION), THE RELATIVE FUNCTION
C             REDUCTION PREDICTED FOR THE STEP JUST TAKEN (I.E.,
C             PRELDF = V(PREDUC) / F0, WHERE V(PREDUC) IS DESCRIBED
C             BELOW), THE SCALED RELATIVE CHANGE IN X (SEE V(RELDX)
C             BELOW), THE MODELS USED IN THE CURRENT ITERATION (G =
C             GAUSS-NEWTON, S=AUGMENTED), THE MARQUARDT PARAMETER
C             STPPAR USED IN COMPUTING THE LAST STEP, THE SIZING FACTOR
C             USED IN UPDATING S, THE 2-NORM OF THE SCALE VECTOR D
C             TIMES THE STEP JUST TAKEN (SEE REF. 1), AND NPRELDF, I.E.,
C             V(NREDUC)/F0, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF
C             NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION
C             REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH
C             STPPAR = 0).  IF NPRELDF IS ZERO, EITHER THE GRADIENT
C             VANISHES (AS DOES PRELDF) OR ELSE THE AUGMENTED MODEL
C             IS BEING USED AND ITS HESSIAN IS INDEFINITE (WITH PRELDF
C             POSITIVE).  IF NPRELDF IS NEGATIVE, THEN IT IS THE NEGA-
C             OF THE RELATIVE FUNCTION REDUCTION PREDICTED FOR A STEP
C             COMPUTED WITH STEP BOUND V(LMAX0) FOR USE IN TESTING FOR
C             SINGULAR CONVERGENCE.
C                  IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF MAXIMUM
C             LENGTH 79 (OR 55 IS IV(COVPRT) = 0) ARE PRINTED, INCLUD-
C             ING ONLY THE FIRST 6 ITEMS LISTED ABOVE (THROUGH RELDX).
C             DEFAULT = 1.
C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A
C             FRESH START OR ANY CHANGED V VALUES ON A RESTART.
C             IV(PARPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING
C             IS DONE.  IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING.
C             (SETTING IV(PRUNIT) TO 0 IS THE ONLY WAY TO SUPPRESS THE
C             ONE-LINE TERMINATION REASON MESSAGE PRINTED BY ITSMRY.)
C             DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS).
C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS
C             WELL AS THE CORRESPONDING GRADIENT AND SCALE VECTOR D).
C             IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN-
C             ING.  THESE CONSIST OF THE FUNCTION VALUE (HALF THE SUM
C             OF SQUARES) AT X, V(RELDX) (SEE BELOW), THE NUMBER OF
C             FUNCTION AND GRADIENT EVALUATIONS (CALLS ON CALCR AND
C             CALCJ RESPECTIVELY, EXCLUDING ANY CALLS USED TO COMPUTE
C             THE COVARIANCE), THE RELATIVE FUNCTION REDUCTIONS PREDICT-
C             ED FOR THE LAST STEP TAKEN AND FOR A NEWTON STEP (OR PER-
C             HAPS A STEP BOUNDED BY V(LMAX0) -- SEE THE DESCRIPTIONS
C             OF PRELDF AND NPRELDF UNDER IV(OUTLEV) ABOVE), AND (IF AN
C             ATTEMPT WAS MADE TO COMPUTE THE COVARIANCE) THE NUMBER OF
C             CALLS ON CALCR AND CALCJ USED IN TRYING TO COMPUTE THE
C             COVARIANCE.  IV(STATPR) = 0 MEANS SKIP THIS PRINTING.
C             DEFAULT = 1.
C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D
C             (ON A FRESH START ONLY).  IV(X0PRT) = 0 MEANS SKIP THIS
C             PRINTING.  DEFAULT = 1.
C
C  ***  (SELECTED) IV OUTPUT VALUES  ***
C
C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE....
C             3 = X-CONVERGENCE.  THE SCALED RELATIVE DIFFERENCE BE-
C                  TWEEN THE CURRENT PARAMETER VECTOR X AND A LOCALLY
C                  OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT MOST
C                  V(XCTOL).
C             4 = RELATIVE FUNCTION CONVERGENCE.  THE RELATIVE DIFFER-
C                  ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO-
C                  CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL).
C             5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE
C                  CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD).
C             6 = ABSOLUTE FUNCTION CONVERGENCE.  THE CURRENT FUNCTION
C                  VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE.
C             7 = SINGULAR CONVERGENCE.  THE HESSIAN NEAR THE CURRENT
C                  ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A
C                  STEP OF LENGTH AT MOST V(LMAX0) IS UNLIKELY TO YIELD
C                  A RELATIVE FUNCTION DECREASE OF MORE THAN V(RFCTOL).
C             8 = FALSE CONVERGENCE.  THE ITERATES APPEAR TO BE CONVERG-
C                  ING TO A NONCRITICAL POINT.  THIS MAY MEAN THAT THE
C                  CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL),
C                  V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH
C                  THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT
C                  THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT
C                  THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X.
C             9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON-
C                  VERGENCE (SEE IV(MXFCAL)).
C            10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE
C                  (SEE IV(MXITER)).
C            11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT).  SEE THE
C                  USAGE NOTES BELOW.
C            13 = F(X) CANNOT BE COMPUTED AT THE INITIAL X.
C            14 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT
C                  OCCUR).
C            15 = THE JACOBIAN COULD NOT BE COMPUTED AT X (SEE CALCJ
C                  ABOVE).
C            16 = N OR P (OR PARAMETER NN TO NL2ITR) OUT OF RANGE --
C                  P .LE. 0 OR N .LT. P OR NN .LT. N.
C            17 = RESTART ATTEMPTED WITH N OR P (OR PAR. NN TO NL2ITR)
C                  CHANGED.
C            18 = IV(INITS) IS OUT OF RANGE.
C            19...45 = V(IV(1)) IS OUT OF RANGE.
C            50 = IV(1) WAS OUT OF RANGE.
C            87...(86+P) = JTOL(IV(1)-86) (I.E., V(IV(1)) IS NOT
C                  POSITIVE (SEE V(DFAC) BELOW).
C IV(COVMAT)... IV(26) TELLS WHETHER A COVARIANCE MATRIX WAS COMPUTED.
C             IF (IV(COVMAT) IS POSITIVE, THEN THE LOWER TRIANGLE OF
C             THE COVARIANCE MATRIX IS STORED ROWWISE IN V STARTING AT
C             V(IV(COVMAT)).  IF IV(COVMAT) = 0, THEN NO ATTEMPT WAS
C             MADE TO COMPUTE THE COVARIANCE.  IF IV(COVMAT) = -1,
C             THEN THE FINITE-DIFFERENCE HESSIAN WAS INDEFINITE.  AND
C             AND IF IV(COVMAT) = -2, THEN A SUCCESSFUL FINITE-DIFFER-
C             ENCING STEP COULD NOT BE FOUND FOR SOME COMPONENT OF X
C             (I.E., CALCR SET NF TO 0 FOR EACH OF TWO TRIAL STEPS).
C             NOTE THAT IV(COVMAT) IS RESET TO 0 AFTER EACH SUCCESSFUL
C             STEP, SO IF SUCH A STEP IS TAKEN AFTER A RESTART, THEN
C             THE COVARIANCE MATRIX WILL BE RECOMPUTED.
C IV(D)........ IV(27) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
C             SCALE VECTOR D.
C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
C             LEAST-SQUARES GRADIENT VECTOR (J**T)*R.
C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCR (I.E.,
C             FUNCTION EVALUATIONS, INCLUDING THOSE USED IN COMPUTING
C             THE COVARIANCE).
C IV(NFCOV).... IV(40) IS THE NUMBER OF CALLS MADE ON CALCR WHEN
C             TRYING TO COMPUTE COVARIANCE MATRICES.
C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON
C             CALCJ) SO FAR DONE (INCLUDING THOSE USED FOR COMPUTING
C             THE COVARIANCE).
C IV(NGCOV).... IV(41) IS THE NUMBER OF CALLS MADE ON CALCJ WHEN
C             TRYING TO COMPUTE COVARIANCE MATRICES.
C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED.
C IV(R)........ IV(50) IS THE STARTING SUBSCRIPT IN V OF THE RESIDUAL
C             VECTOR R CORRESPONDING TO X.
C
C  ***  (SELECTED) V INPUT VALUES (FROM SUBROUTINE DFAULT)  ***
C
C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.
C             IF NL2SOL FINDS A POINT WHERE THE FUNCTION VALUE (HALF
C             THE SUM OF SQUARES) IS LESS THAN V(AFCTOL), AND IF NL2SOL
C             DOES NOT RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS
C             WITH IV(1) = 6.  DEFAULT = MAX(10**-20, MACHEP**2), WHERE
C             MACHEP IS THE UNIT ROUNDOFF.
C V(DELTA0)... V(44) IS A FACTOR USED IN CHOOSING THE FINITE-DIFFERENCE
C             STEP SIZE USED IN COMPUTING THE COVARIANCE MATRIX WHEN
C             IV(COVREQ) = 1 OR 2.  FOR COMPONENT I, STEP SIZE
C                  V(DELTA0) * MAX(ABS(X(I)), 1/D(I)) * SIGN(X(I))
C             IS USED, WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).
C             (IF THIS STEP RESULTS IN CALCR SETTING NF TO 0, THEN -0.5
C             TIMES THIS STEP IS ALSO TRIED.)  DEFAULT = MACHEP**0.5,
C             WHERE MACHEP IS THE UNIT ROUNDOFF.
C V(DFAC)..... V(41) AND THE D0 AND JTOL ARRAYS (SEE V(D0INIT) AND
C             V(JTINIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
C             IV(DTYPE) .GT. 0.  (D IS INITIALIZED ACCORDING TO
C             V(DINIT).)  LET D1(I) =
C               MAX(SQRT(JCNORM(I)**2 + MAX(S(I,I),0)), V(DFAC)*D(I)),
C             WHERE JCNORM(I) IS THE 2-NORM OF THE I-TH COLUMN OF THE
C             CURRENT JACOBIAN MATRIX AND S IS THE S MATRIX OF REF. 1.
C             IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) UNLESS
C             D1(I) .LT. JTOL(I), IN WHICH CASE D(I) IS SET TO
C                                MAX(D0(I), JTOL(I)).
C             IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
C             ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
C             DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
C             DEFAULT = 0.6.
C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE
C             VECTOR D IS INITIALIZED.  DEFAULT = 0.
C V(DLTFDC)... V(40) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
C             COVARIANCE MATRIX WHEN IV(COVREQ) = -1 OR -2.  FOR
C             DIFFERENCES INVOLVING X(I), THE STEP SIZE FIRST TRIED IS
C                       V(DLTFDC) * MAX(ABS(X(I)), 1/D(I)),
C             WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).  (IF
C             THIS STEP IS TOO BIG THE FIRST TIME IT IS TRIED, I.E., IF
C             CALCR SETS NF TO 0, THEN -0.5 TIMES THIS STEP IS ALSO
C             TRIED.)  DEFAULT = MACHEP**(1/3), WHERE MACHEP IS THE
C             UNIT ROUNDOFF.
C V(D0INIT)... V(37), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
C             OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED.  IF
C             V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
C             STORED D0 IN V STARTING AT V(P+87).  DEFAULT = 1.0.
C V(JTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
C             OF THE JTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED.  IF
C             V(JTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
C             STORED JTOL IN V STARTING AT V(87).  DEFAULT = 10**-6.
C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE
C             VERY FIRST STEP THAT NL2SOL ATTEMPTS.  IT IS ALSO USED
C             IN TESTING FOR SINGULAR CONVERGENCE -- IF THE FUNCTION
C             REDUCTION PREDICTED FOR A STEP OF LENGTH BOUNDED BY
C             V(LMAX0) IS AT MOST V(RFCTOL) * ABS(F0), WHERE  F0  IS
C             THE FUNCTION VALUE AT THE START OF THE CURRENT ITERATION,
C             AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, OR 6,
C             THEN IT RETURNS WITH IV(1) = 7.    DEFAULT = 100.
C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE.
C             IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION
C             REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) AT
C             THE START OF THE CURRENT ITERATION, WHERE  F0  IS THE
C             THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT-
C             ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION
C             DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 4 (OR 5).
C             DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS
C             THE UNIT ROUNDOFF.
C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE
C             AND TO CONSIDER SWITCHING MODELS.  THIS IS DONE IF THE
C             ACTUAL FUNCTION DECREASE FROM THE CURRENT STEP IS NO MORE
C             THAN V(TUNER1) TIMES ITS PREDICTED VALUE.  DEFAULT = 0.1.
C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE.  IF A NEWTON STEP
C             (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL)
C             AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC-
C             TION DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 3 (OR 5).
C             (SEE THE DESCRIPTION OF V(RELDX) BELOW.)
C             DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF.
C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE.  IF A STEP IS
C             TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT-
C             ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL),
C             AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR
C             7, THEN IT RETURNS WITH IV(1) = 8.  (SEE THE DESCRIPTION
C             OF V(RELDX) BELOW.)  DEFAULT = 100*MACHEP, WHERE
C             MACHEP IS THE UNIT ROUNDOFF.
C V(*)........ DFAULT SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH
C             WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER.  SEE
C             VERSION 2.2 OF THE NL2SOL USAGE SUMMARY (WHICH IS AN
C             APPENDIX TO REF. 1).
C
C  ***  (SELECTED) V OUTPUT VALUES  ***
C
C V(DGNORM)... V(1) IS THE 2-NORM OF (D**-1)*G, WHERE G IS THE MOST RE-
C             CENTLY COMPUTED GRADIENT AND D IS THE CORRESPONDING SCALE
C             VECTOR.
C V(DSTNRM)... V(2) IS THE 2-NORM OF D*STEP, WHERE STEP IS THE MOST RE-
C             CENTLY COMPUTED STEP AND D IS THE CURRENT SCALE VECTOR.
C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE (HALF THE SUM OF
C             SQUARES).
C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT
C             ITERATION.
C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION
C             POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC-
C             TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E.,
C             STEP = -H**-1 * G,  WHERE  G = (J**T) * R  IS THE CURRENT
C             GRADIENT AND H IS THE CURRENT HESSIAN APPROXIMATION --
C             H = (J**T)*J  FOR THE GAUSS-NEWTON MODEL AND
C             H = (J**T)*J + S  FOR THE AUGMENTED MODEL).
C                  V(NREDUC) = ZERO MEANS H IS NOT POSITIVE DEFINITE.
C                  IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF
C             THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH
C             A STEP BOUND OF V(LMAX0) FOR USE IN TESTING FOR SINGULAR
C             CONVERGENCE.
C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT
C             QUADRATIC MODEL) FOR THE CURRENT STEP.  THIS (DIVIDED BY
C             V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION
C             CONVERGENCE.
C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE
C             CURRENT STEP, COMPUTED AS
C                  MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) /
C                     MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P),
C             WHERE X = X0 + STEP.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE REF. 1 FOR A DESCRIPTION OF THE ALGORITHM USED.
C        ON PROBLEMS WHICH ARE NATURALLY WELL SCALED, BETTER PERFORM-
C     ANCE MAY BE OBTAINED BY SETTING V(D0INIT) = 1.0 AND IV(DTYPE) = 0,
C     WHICH WILL CAUSE THE SCALE VECTOR D TO BE SET TO ALL ONES.
C
C  ***  USAGE NOTES  ***
C
C        AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART,
C     I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE
C     AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT-
C     ED.  IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV
C     AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DFAULT).
C        THOSE WHO DO NOT WISH TO WRITE A CALCJ WHICH COMPUTES THE JA-
C     COBIAN MATRIX ANALYTICALLY SHOULD CALL NL2SNO RATHER THAN NL2SOL.
C     NL2SNO USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE JACOBIAN.
C        THOSE WHO WOULD PREFER TO PROVIDE R AND J (THE RESIDUAL AND
C     JACOBIAN) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU-
C     TINES CALCR AND CALCJ MAY CALL ON NL2ITR DIRECTLY.  SEE THE COM-
C     MENTS AT THE BEGINNING OF NL2ITR.
C        THOSE WHO USE NL2SOL INTERACTIVELY MAY WISH TO SUPPLY THEIR
C     OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY
C     HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED.  THIS MAKES IT POS-
C     SIBLE TO EXTERNALLY INTERRUPT NL2SOL (WHICH WILL RETURN WITH
C     IV(1) = 11 IF STOPX RETURNS .TRUE.).
C        STORAGE FOR J IS ALLOCATED AT THE END OF V.  THUS THE CALLER
C     MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCJ TO USE
C     ELEMENTS OF J BEYOND THE FIRST N*P AS SCRATCH STORAGE.
C
C  ***  PORTABILITY NOTES  ***
C
C        THE NL2SOL DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE-
C     PRECISION VERSIONS OF THE NL2SOL SOURCE CODE, SO IT SHOULD BE UN-
C     NECESSARY TO CHANGE PRECISIONS.
C        ONLY THE FUNCTIONS IMDCON AND RMDCON CONTAIN MACHINE-DEPENDENT
C     CONSTANTS.  TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD
C     SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS.
C        INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED.  ON CERTAIN COM-
C     PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE
C     DECLARATIONS.  SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE
C     PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+
C     IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY
C     A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72.
C        THE NL2SOL SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD
C     FORTRAN.  IT MAY BE CONVERTED TO FORTRAN 77 BY
C     COMMENTING OUT ALL LINES THAT FALL BETWEEN A LINE HAVING C/6 IN
C     COLUMNS 1-3 AND A LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING
C     (I.E., REPLACING BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT
C     FOLLOW THE C/7 LINE AND PRECEED A LINE HAVING C/ IN COLUMNS 1-2
C     AND BLANKS IN COLUMNS 3-72.  THESE CHANGES CONVERT SOME DATA
C     STATEMENTS INTO PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM
C     REAL TO CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE
C     THESE VARIABLES USE CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD
C     OF HOLLERITH CONSTANTS.  (SUCH VARIABLES AND DATA STATEMENTS
C     APPEAR ONLY IN MODULES ITSMRY AND PARCHK.  PARAMETER STATEMENTS
C     APPEAR NEARLY EVERYWHERE.)
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY (WINTER 1979 - WINTER 1980).
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C----------------------------  DECLARATIONS  ---------------------------
C
      EXTERNAL ITSMRY, NL2ITR
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO-
C             RITHM.
C
      LOGICAL STRTED
      INTEGER D1, J1, NF, R1
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER D, J, NFCALL, NFGCAL, R, TOOBIG
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA NFCALL/6/, NFGCAL/7/, TOOBIG/2/
C/7
C     PARAMETER (NFCALL=6, NFGCAL=7, TOOBIG=2)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA D/27/, J/33/, R/50/
C/7
C     PARAMETER (D=27, J=33, R=50)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      D1 = 94 + 2*N + P*(3*P + 31)/2
      IV(D) = D1
      R1 = D1 + P
      IV(R) = R1
      J1 = R1 + N
      IV(J) = J1
      STRTED = .TRUE.
      IF (IV(1) .NE. 0 .AND. IV(1) .NE. 12) GO TO 40
         STRTED = .FALSE.
         IV(NFCALL) = 1
         IV(NFGCAL) = 1
C
 10   NF = IV(NFCALL)
      CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
      IF (STRTED) GO TO 20
         IF (NF .GT. 0) GO TO 30
              IV(1) = 13
              GO TO 60
C
 20   IF (NF .LE. 0) IV(TOOBIG) = 1
      GO TO 40
C
 30   CALL CALCJ(N, P, X, IV(NFGCAL), V(J1), UIPARM, URPARM, UFPARM)
      IF (IV(NFGCAL) .EQ. 0) GO TO 50
      STRTED = .TRUE.
C
 40   CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X)
      IF (IV(1) - 2) 10, 30, 999
C
 50   IV(1) = 15
 60   CALL ITSMRY(V(D1), IV, P, V, X)
C
 999  RETURN
C  ***  LAST CARD OF NL2SOL FOLLOWS  ***
      END
      SUBROUTINE NL2SNO(N, P, X, CALCR, IV, V, UIPARM, URPARM, UFPARM)  SNO00010
C
C  ***  LIKE NL2SOL, BUT WITHOUT CALCJ -- MINIMIZE NONLINEAR SUM OF  ***
C  ***  SQUARES USING FINITE-DIFFERENCE JACOBIAN APPROXIMATIONS      ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
      INTEGER N, P, IV(1), UIPARM(1)
      REAL X(P), V(1), URPARM(1)
C     DIMENSION IV(60+P),  V(93 + N*P + 3*N + P*(3*P+33)/2)
      EXTERNAL CALCR, UFPARM
C
C-----------------------------  DISCUSSION  ----------------------------
C
C        THE PARAMETERS FOR NL2SNO ARE THE SAME AS THOSE FOR NL2SOL
C     (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED.  INSTEAD OF CALLING
C     CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, NL2SNO COMPUTES
C     AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
C     V(DLTFDJ) BELOW.  NL2SNO USES FUNCTION VALUES ONLY WHEN COMPUT-
C     THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS
C     THAT NL2SOL MAY USE).  TO DO SO, NL2SNO SETS IV(COVREQ) TO -1 IF
C     IV(COVPRT) = 1 WITH IV(COVREQ) = 0 AND TO MINUS ITS ABSOLUTE
C     VALUE OTHERWISE.  THUS V(DELTA0) IS NEVER REFERENCED AND ONLY
C     V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC).
C        THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
C     BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
C     COUNT IV(NFCALL) AND ARE NOT OTHERWISE REPORTED.
C
C V(DLTFDJ)... V(36) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
C             FINITE-DIFFERENCE JACOBIAN MATRIX.  FOR DIFFERENCES IN-
C             VOLVING X(I), THE STEP SIZE FIRST TRIED IS
C                       V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
C             WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).  (IF
C             THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
C             SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
C             LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
C             DEFAULT = MACHEP**0.5.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++  DECLARATIONS  ++++++++++++++++++++++++++++
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      REAL ABS, AMAX1
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DFAULT, ITSMRY, NL2ITR, RMDCON, VSCOPY
      REAL RMDCON
C
C DFAULT... SUPPLIES DEFAULT PARAMETER VALUES.
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO-
C             RITHM.
C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
      LOGICAL STRTED
      INTEGER DK, D1, I, J1, J1K, K, NF, RN, R1, DINIT
      REAL H, HFAC, HLIM, NEGPT5, ONE, XK, ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER COVPRT, COVREQ, D, DLTFDJ, DTYPE, J, NFCALL, NFGCAL, R,
     1        TOOBIG
C
C/6
      DATA HFAC/1.E+3/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (HFAC=1.D+3, NEGPT5=-0.5D+0, ONE=1.D+0, ZERO=0.D+0)
C/
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA COVPRT/14/, COVREQ/15/, D/27/, DTYPE/16/, J/33/,
     1     NFCALL/6/, NFGCAL/7/, R/50/, TOOBIG/2/
C/7
C     PARAMETER (COVPRT=14, COVREQ=15, D=27, DTYPE=16, J=33,
C    1     NFCALL=6, NFGCAL=7, R=50, TOOBIG=2)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA DLTFDJ/36/, DINIT/38/
C/7
C     PARAMETER (DLTFDJ=36)
C     SAVE HLIM
C/
      DATA HLIM/0.E+0/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      D1 = 94 + 2*N + P*(3*P + 31)/2
      IV(D) = D1
      R1 = D1 + P
      IV(R) = R1
      J1 = R1 + N
      IV(J) = J1
      RN = J1 - 1
      IF (IV(1) .EQ. 0) CALL DFAULT(IV, V)
      IV(COVREQ) = -IABS(IV(COVREQ))
      IF (IV(COVPRT) .NE. 0 .AND. IV(COVREQ) .EQ. 0) IV(COVREQ) = -1
      STRTED = .TRUE.
      IF (IV(1) .NE. 12) GO TO 80
         STRTED = .FALSE.
         IV(NFCALL) = 1
         IV(NFGCAL) = 1
C        ***  INITIALIZE SCALE VECTOR D TO ONES FOR COMPUTING
C        ***  INITIAL JACOBIAN.
         IF (IV(DTYPE) .GT. 0) CALL VSCOPY(P, V(D1), ONE)
       IF (V(DINIT).GT.ZERO) CALL VSCOPY(P, V(D1), V(DINIT))
C
 10   NF = IV(NFCALL)
      CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
      IF (STRTED) GO TO 20
         IF (NF .GT. 0) GO TO 30
              IV(1) = 13
              GO TO 90
C
 20   IF (NF .LE. 0) IV(TOOBIG) = 1
      GO TO 80
C
C  ***  COMPUTE FINITE-DIFFERENCE JACOBIAN  ***
C
 30   J1K = J1
      DK = D1
      DO 70 K = 1, P
         XK = X(K)
         H = V(DLTFDJ) * AMAX1(ABS(XK), ONE/V(DK))
         DK = DK + 1
 40      X(K) = XK + H
         NF = IV(NFGCAL)
         CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM)
         IF (NF .GT. 0) GO TO 50
              IF (HLIM .EQ. ZERO) HLIM = HFAC * RMDCON(3)
C             ***  HLIM = HFAC TIMES THE UNIT ROUNDOFF  ***
              H = NEGPT5 * H
              IF (ABS(H) .GE. HLIM) GO TO 40
                   IV(1) = 15
                   GO TO 90
 50      X(K) = XK
         DO 60 I = R1, RN
              V(J1K) = (V(J1K) - V(I)) / H
              J1K = J1K + 1
 60           CONTINUE
 70      CONTINUE
C
      STRTED = .TRUE.
C
 80   CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X)
      IF (IV(1) - 2) 10, 30, 999
C
 90   CALL ITSMRY(V(D1), IV, P, V, X)
C
 999  RETURN
C  ***  LAST CARD OF NL2SNO FOLLOWS  ***
      END
      SUBROUTINE NL2ITR (D, IV, J, N, NN, P, R, V, X)                   ITR00010
C
C  ***  CARRY OUT NL2SOL (NONLINEAR LEAST-SQUARES) ITERATIONS  ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IV(1), N, NN, P
      REAL D(P), J(NN,P), R(N), V(1), X(P)
C     DIMENSION IV(60+P), V(93 + 2*N + P*(3*P+31)/2)
C
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C D.... SCALE VECTOR.
C IV... INTEGER VALUE ARRAY.
C J.... N BY P JACOBIAN MATRIX (LEAD DIMENSION NN).
C N.... NUMBER OF OBSERVATIONS (COMPONENTS IN R).
C NN... LEAD DIMENSION OF J.
C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
C R.... RESIDUAL VECTOR.
C V.... FLOATING-POINT VALUE ARRAY.
C X.... PARAMETER VECTOR.
C
C  ***  DISCUSSION  ***
C
C        PARAMETERS IV, N, P, V, AND X ARE THE SAME AS THE CORRESPOND-
C     ING ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER
C     (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS
C     NOT NEEDED).  MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE
C     TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW,
C     AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL).  THE VALUES IV(D),
C     IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND
C     NL2SNO), ARE NOT REFERENCED BY NL2ITR OR THE SUBROUTINES IT CALLS.
C        ON A FRESH START, I.E., A CALL ON NL2ITR WITH IV(1) = 0 OR 12,
C     NL2ITR ASSUMES THAT R = R(X), THE RESIDUAL AT X, AND J = J(X),
C     THE CORRESPONDING JACOBIAN MATRIX OF R AT X.
C
C IV(1) = 1 MEANS THE CALLER SHOULD SET R TO R(X), THE RESIDUAL AT X,
C             AND CALL NL2ITR AGAIN, HAVING CHANGED NONE OF THE OTHER
C             PARAMETERS.  AN EXCEPTION OCCURS IF R CANNOT BE EVALUATED
C             AT X (E.G. IF R WOULD OVERFLOW), WHICH MAY HAPPEN BECAUSE
C             OF AN OVERSIZED STEP.  IN THIS CASE THE CALLER SHOULD SET
C             IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE NL2ITR TO IG-
C             NORE R AND TRY A SMALLER STEP.  THE PARAMETER NF THAT
C             NL2SOL PASSES TO CALCR (FOR POSSIBLE USE BY CALCJ) IS A
C             COPY OF IV(NFCALL) = IV(6).
C IV(1) = 2 MEANS THE CALLER SHOULD SET J TO J(X), THE JACOBIAN MATRIX
C             OF R AT X, AND CALL NL2ITR AGAIN.  THE CALLER MAY CHANGE
C             D AT THIS TIME, BUT SHOULD NOT CHANGE ANY OF THE OTHER
C             PARAMETERS.  THE PARAMETER NF THAT NL2SOL PASSES TO
C             CALCJ IS IV(NFGCAL) = IV(7).  IF J CANNOT BE EVALUATED
C             AT X, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH
C             CASE NL2ITR WILL RETURN WITH IV(1) = 15.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C        (SEE NL2SOL FOR REFERENCES.)
C
C+++++++++++++++++++++++++++  DECLARATIONS  ++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER DUMMY, DIG1, G1, G01, H0, H1, I, IM1, IPIVI, IPIVK, IPIV1,
     1        IPK, K, KM1, L, LKY1, LMAT1, LSTGST, M, PP1O2, QTR1,
     2        RDK, RD0, RD1, RSAVE1, SMH, SSTEP, STEP1, STPMOD, S1,
     3        TEMP1, TEMP2, W1, X01
      REAL E, RDOF1, STTSST, T, T1
C
C     ***  CONSTANTS  ***
C
      REAL HALF, NEGONE, ONE, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      REAL ABS
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL ASSESS, COVCLC, DOTPRD, DUPDAT, GQTSTP, ITSMRY, LMSTEP,
     1         PARCHK, QAPPLY, QRFACT, RPTMUL, SLUPDT, SLVMUL, STOPX,
     2         VAXPY, VCOPY, VSCOPY, V2NORM
      LOGICAL STOPX
      REAL DOTPRD, V2NORM
C
C ASSESS... ASSESSES CANDIDATE STEP.
C COVCLC... COMPUTES COVARIANCE MATRIX.
C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS.
C DUPDAT... UPDATES SCALE VECTOR D.
C GQTSTP... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C LMSTEP... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
C PARCHK... CHECKS VALIDITY OF INPUT IV AND V VALUES.
C QAPPLY... APPLIES ORTHOGONAL MATRIX Q FROM QRFACT TO A VECTOR.
C QRFACT... COMPUTES QR DECOMPOSITION OF A MATRIX VIA HOUSEHOLDER TRANS.
C RPTMUL... MULTIPLIES VECTOR BY THE R MATRIX (AND/OR ITS TRANSPOSE)
C             STORED BY QRFACT.
C SLUPDT... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
C             ANGLE OF A SYMMETRIC MATRIX.
C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
C VAXPY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
C VCOPY.... COPIES ONE VECTOR TO ANOTHER.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C V2NORM... RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER CNVCOD, COSMIN, COVMAT, COVPRT, COVREQ, DGNORM, DIG,
     1        DINIT, DSTNRM, DTYPE, D0INIT, F, FDIF, FUZZ,
     2        F0, G, GTSTEP, H, IERR, INCFAC, INITS, IPIVOT, IPIV0, IRC,
     3        JTINIT, JTOL1, KAGQT, KALM, LKY, LMAT, LMAX0, MODE, MODEL,
     4        MXFCAL, MXITER, NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL,
     5        NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, RADINC,
     6        RADIUS, RAD0, RD, RESTOR, RLIMIT, RSAVE, S, SIZE, STEP,
     7        STGLIM, STLSTG, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4,
     8        TUNER5, VSAVE1, W, WSCALE, XIRC, X0
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA CNVCOD/34/, COVMAT/26/, COVPRT/14/,
     1     COVREQ/15/, DIG/43/, DTYPE/16/, G/28/, H/44/,
     2     IERR/32/, INITS/25/, IPIVOT/61/, IPIV0/60/,
     3     IRC/3/, KAGQT/35/, KALM/36/, LKY/37/, LMAT/58/,
     4     MODE/38/, MODEL/5/, MXFCAL/17/, MXITER/18/,
     5     NFCALL/6/, NFGCAL/7/, NFCOV/40/, NGCOV/41/,
     6     NGCALL/30/, NITER/31/, QTR/49/,
     7     RADINC/8/, RD/51/, RESTOR/9/, RSAVE/52/, S/53/,
     8     STEP/55/, STGLIM/11/, STLSTG/56/, SUSED/57/,
     9     SWITCH/12/, TOOBIG/2/, W/59/, XIRC/13/, X0/60/
C/7
C     PARAMETER (CNVCOD=34, COVMAT=26, COVPRT=14,
C    1     COVREQ=15, DIG=43, DTYPE=16, G=28, H=44,
C    2     IERR=32, INITS=25, IPIVOT=61, IPIV0=60,
C    3     IRC=3, KAGQT=35, KALM=36, LKY=37, LMAT=58,
C    4     MODE=38, MODEL=5, MXFCAL=17, MXITER=18,
C    5     NFCALL=6, NFGCAL=7, NFCOV=40, NGCOV=41,
C    6     NGCALL=30, NITER=31, QTR=49,
C    7     RADINC=8, RD=51, RESTOR=9, RSAVE=52, S=53,
C    8     STEP=55, STGLIM=11, STLSTG=56, SUSED=57,
C    9     SWITCH=12, TOOBIG=2, W=59, XIRC=13, X0=60)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA COSMIN/43/, DGNORM/1/, DINIT/38/, DSTNRM/2/,
     1     D0INIT/37/, F/10/, FDIF/11/, FUZZ/45/,
     2     F0/13/, GTSTEP/4/, INCFAC/23/,
     3     JTINIT/39/, JTOL1/87/, LMAX0/35/,
     4     NVSAVE/9/, PHMXFC/21/, PREDUC/7/,
     5     RADFAC/16/, RADIUS/8/, RAD0/9/, RLIMIT/42/,
     6     SIZE/47/, STPPAR/5/, TUNER4/29/, TUNER5/30/,
     7     VSAVE1/78/, WSCALE/48/
C/7
C     PARAMETER (COSMIN=43, DGNORM=1, DINIT=38, DSTNRM=2,
C    1     D0INIT=37, F=10, FDIF=11, FUZZ=45,
C    2     F0=13, GTSTEP=4, INCFAC=23,
C    3     JTINIT=39, JTOL1=87, LMAX0=35,
C    4     NVSAVE=9, PHMXFC=21, PREDUC=7,
C    5     RADFAC=16, RADIUS=8, RAD0=9, RLIMIT=42,
C    6     SIZE=47, STPPAR=5, TUNER4=29, TUNER5=30,
C    7     VSAVE1=78, WSCALE=48)
C/
C
C
C/6
      DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0)
C/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      I = IV(1)
      IF (I .EQ. 1) GO TO 20
      IF (I .EQ. 2) GO TO 50
C
C  ***  CHECK VALIDITY OF IV AND V INPUT VALUES  ***
C
C     ***  NOTE -- IF IV(1) = 0, THEN PARCHK CALLS DFAULT(IV, V)  ***
      CALL PARCHK(IV, N, NN, P, V)
      I = IV(1) - 2
      IF (I .GT. 10) GO TO 999
      GO TO (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), I
C
C  ***  INITIALIZATION AND STORAGE ALLOCATION  ***
C
 10   IV(NITER) = 0
      IV(NFCALL) = 1
      IV(NGCALL) = 1
      IV(NFGCAL) = 1
      IV(MODE) = -1
      IV(STGLIM) = 2
      IV(TOOBIG) = 0
      IV(CNVCOD) = 0
      IV(COVMAT) = 0
      IV(NFCOV) = 0
      IV(NGCOV) = 0
      IV(KALM) = -1
      IV(RADINC) = 0
      IV(S) = JTOL1 + 2*P
      PP1O2 = P * (P + 1) / 2
      IV(X0) = IV(S) + PP1O2
      IV(STEP) = IV(X0) + P
      IV(STLSTG) = IV(STEP) + P
      IV(DIG) = IV(STLSTG) + P
      IV(G) = IV(DIG) + P
      IV(LKY) = IV(G) + P
      IV(RD) = IV(LKY) + P
      IV(RSAVE) = IV(RD) + P
      IV(QTR) = IV(RSAVE) + N
      IV(H) = IV(QTR) + N
      IV(W) = IV(H) + PP1O2
      IV(LMAT) = IV(W) + 4*P + 7
C     +++ LENGTH OF W = P*(P+9)/2 + 7.  LMAT IS CONTAINED IN W.
      IF (V(DINIT) .GE. ZERO) CALL VSCOPY(P, D, V(DINIT))
      IF (V(JTINIT) .GT. ZERO) CALL VSCOPY(P, V(JTOL1), V(JTINIT))
      I = JTOL1 + P
      IF (V(D0INIT) .GT. ZERO) CALL VSCOPY(P, V(I), V(D0INIT))
      V(RAD0) = ZERO
      V(STPPAR) = ZERO
      V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
C
C  ***  SET INITIAL MODEL AND S MATRIX  ***
C
      IV(MODEL) = 1
      IF (IV(INITS) .EQ. 2) IV(MODEL) = 2
      S1 = IV(S)
      IF (IV(INITS) .EQ. 0) CALL VSCOPY(PP1O2, V(S1), ZERO)
C
C  ***  COMPUTE FUNCTION VALUE (HALF THE SUM OF SQUARES)  ***
C
 20   T = V2NORM(N, R)
      IF (T .GT. V(RLIMIT)) IV(TOOBIG) = 1
      IF (IV(TOOBIG) .NE. 0) GO TO 30
      V(F) = HALF * T**2
 30   IF (IV(MODE)) 40, 350, 730
C
 40   IF (IV(TOOBIG) .EQ. 0) GO TO 60
         IV(1) = 13
         GO TO 900
C
C  ***  MAKE SURE JACOBIAN COULD BE COMPUTED  ***
C
 50   IF (IV(NFGCAL) .NE. 0) GO TO 60
         IV(1) = 15
         GO TO 900
C
C  ***  COMPUTE GRADIENT  ***
C
 60   IV(KALM) = -1
      G1 = IV(G)
      DO 70 I = 1, P
         V(G1) = DOTPRD(N, R, J(1,I))
         G1 = G1 + 1
 70      CONTINUE
      IF (IV(MODE) .GT. 0) GO TO 710
C
C  ***  UPDATE D AND MAKE COPIES OF R FOR POSSIBLE USE LATER  ***
C
      IF (IV(DTYPE) .GT. 0) CALL DUPDAT(D, IV, J, N, NN, P, V)
      RSAVE1 = IV(RSAVE)
      CALL VCOPY(N, V(RSAVE1), R)
      QTR1 = IV(QTR)
      CALL VCOPY(N, V(QTR1), R)
C
C  ***  COMPUTE  D**-1 * GRADIENT  ***
C
      G1 = IV(G)
      DIG1 = IV(DIG)
      K = DIG1
      DO 80 I = 1, P
         V(K) = V(G1) / D(I)
         K = K + 1
         G1 = G1 + 1
 80      CONTINUE
      V(DGNORM) = V2NORM(P, V(DIG1))
C
      IF (IV(CNVCOD) .NE. 0) GO TO 700
      IF (IV(MODE) .EQ. 0) GO TO 570
      IV(MODE) = 0
C
C
C-----------------------------  MAIN LOOP  -----------------------------
C
C
C  ***  PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT  ***
C
 150  CALL ITSMRY(D, IV, P, V, X)
 160  K = IV(NITER)
      IF (K .LT. IV(MXITER)) GO TO 170
         IV(1) = 10
         GO TO 900
 170  IV(NITER) = K + 1
C
C  ***  UPDATE RADIUS  ***
C
      IF (K .EQ. 0) GO TO 185
      STEP1 = IV(STEP)
      DO 180 I = 1, P
         V(STEP1) = D(I) * V(STEP1)
         STEP1 = STEP1 + 1
 180     CONTINUE
      STEP1 = IV(STEP)
      V(RADIUS) = V(RADFAC) * V2NORM(P, V(STEP1))
C
C  ***  INITIALIZE FOR START OF NEXT ITERATION  ***
C
 185  X01 = IV(X0)
      V(F0) = V(F)
      IV(KAGQT) = -1
      IV(IRC) = 4
      IV(H) = -IABS(IV(H))
      IV(SUSED) = IV(MODEL)
C
C     ***  COPY X TO X0  ***
C
      CALL VCOPY(P, V(X01), X)
C
C  ***  CHECK STOPX AND FUNCTION EVALUATION LIMIT  ***
C
 190  IF (.NOT. STOPX(DUMMY)) GO TO 200
         IV(1) = 11
         GO TO 205
C
C     ***  COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
C
 195  IF (V(F) .GE. V(F0)) GO TO 200
         V(RADFAC) = ONE
         K = IV(NITER)
         GO TO 170
C
 200  IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 210
         IV(1) = 9
 205     IF (V(F) .GE. V(F0)) GO TO 900
C
C        ***  IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
C        ***  IMPROVED V(F), EVALUATE THE GRADIENT AT X.
C
              IV(CNVCOD) = IV(1)
              GO TO 560
C
C. . . . . . . . . . . . .  COMPUTE CANDIDATE STEP  . . . . . . . . . .
C
 210  STEP1 = IV(STEP)
      W1 = IV(W)
      IF (IV(MODEL) .EQ. 2) GO TO 240
C
C  ***  COMPUTE LEVENBERG-MARQUARDT STEP  ***
C
         QTR1 = IV(QTR)
         IF (IV(KALM) .GE. 0) GO TO 215
              RD1 = IV(RD)
              IF (-1 .EQ. IV(KALM)) CALL QRFACT(NN, N, P, J, V(RD1),
     1                                   IV(IPIVOT), IV(IERR), 0, V(W1))
              CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR))
 215     H1 = IV(H)
         IF (H1 .GT. 0) GO TO 230
C
C        ***  COPY R MATRIX TO H  ***
C
              H1 = -H1
              IV(H) = H1
              K = H1
              RD1 = IV(RD)
              V(K) = V(RD1)
              IF (P .EQ. 1) GO TO 230
              DO 220 I = 2, P
                   CALL VCOPY(I-1, V(K+1), J(1,I))
                   K = K + I
                   RD1 = RD1 + 1
                   V(K) = V(RD1)
 220               CONTINUE
C
 230     G1 = IV(G)
         CALL LMSTEP(D, V(G1), IV(IERR), IV(IPIVOT), IV(KALM), P,
     1               V(QTR1), V(H1), V(STEP1), V, V(W1))
         GO TO 310
C
C  ***  COMPUTE GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL)  ***
C
 240  IF (IV(H) .GT. 0) GO TO 300
C
C     ***  SET H TO  D**-1 * ( (J**T)*J + S) ) * D**-1.  ***
C
         H1 = -IV(H)
         IV(H) = H1
         S1 = IV(S)
         IF (-1 .NE. IV(KALM)) GO TO 270
C
C        ***  J IS IN ITS ORIGINAL FORM  ***
C
              DO 260 I = 1, P
                   T = ONE / D(I)
                   DO 250 K = 1, I
                        V(H1) = T*(DOTPRD(N,J(1,I),J(1,K))+V(S1)) / D(K)
                        H1 = H1 + 1
                        S1 = S1 + 1
 250                    CONTINUE
 260               CONTINUE
              GO TO 300
C
C  ***  LMSTEP HAS APPLIED QRFACT TO J  ***
C
 270     SMH = S1 - H1
         H0 = H1 - 1
         IPIV1 = IV(IPIVOT)
         T1 = ONE / D(IPIV1)
         RD0 = IV(RD) - 1
         RDOF1 = V(RD0 + 1)
         DO 290 I = 1, P
              L = IPIV0 + I
              IPIVI = IV(L)
              H1 = H0 + IPIVI*(IPIVI-1)/2
              L = H1 + IPIVI
              M = L + SMH
C             ***  V(L) = H(IPIVOT(I), IPIVOT(I))  ***
C             ***  V(M) = S(IPIVOT(I), IPIVOT(I))  ***
              T = ONE / D(IPIVI)
              RDK = RD0 + I
              E = V(RDK)**2
              IF (I .GT. 1) E = E + DOTPRD(I-1, J(1,I), J(1,I))
              V(L) = (E + V(M)) * T**2
              IF (I .EQ. 1) GO TO 290
              L = H1 + IPIV1
              IF (IPIVI .LT. IPIV1) L = L +
     1                               ((IPIV1-IPIVI)*(IPIV1+IPIVI-3))/2
              M = L + SMH
C             ***  V(L) = H(IPIVOT(I), IPIVOT(1))  ***
C             ***  V(M) = S(IPIVOT(I), IPIVOT(1))  ***
              V(L) = T * (RDOF1 * J(1,I)  +  V(M)) * T1
              IF (I .EQ. 2) GO TO 290
              IM1 = I - 1
              DO 280 K = 2, IM1
                   IPK = IPIV0 + K
                   IPIVK = IV(IPK)
                   L = H1 + IPIVK
                   IF (IPIVI .LT. IPIVK) L = L +
     1                               ((IPIVK-IPIVI)*(IPIVK+IPIVI-3))/2
                   M = L + SMH
C                  ***  V(L) = H(IPIVOT(I), IPIVOT(K))  ***
C                  ***  V(M) = S(IPIVOT(I), IPIVOT(K))  ***
                   KM1 = K - 1
                   RDK = RD0 + K
                   V(L) = T * (DOTPRD(KM1, J(1,I), J(1,K)) +
     1                            V(RDK)*J(K,I) + V(M)) / D(IPIVK)
 280               CONTINUE
 290          CONTINUE
C
C  ***  COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP  ***
C
 300  H1 = IV(H)
      DIG1 = IV(DIG)
      LMAT1 = IV(LMAT)
      CALL GQTSTP(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1),
     1            V, V(W1))
C
C
C  ***  COMPUTE R(X0 + STEP)  ***
C
 310  IF (IV(IRC) .EQ. 6) GO TO 350
      X01 = IV(X0)
      STEP1 = IV(STEP)
      CALL VAXPY(P, X, ONE, V(STEP1), V(X01))
      IV(NFCALL) = IV(NFCALL) + 1
      IV(1) = 1
      IV(TOOBIG) = 0
      GO TO 999
C
C. . . . . . . . . . . . .  ASSESS CANDIDATE STEP  . . . . . . . . . . .
C
 350  STEP1 = IV(STEP)
      LSTGST = IV(STLSTG)
      X01 = IV(X0)
      CALL ASSESS(D, IV, P, V(STEP1), V(LSTGST), V, X, V(X01))
C
C  ***  IF NECESSARY, SWITCH MODELS AND/OR RESTORE R  ***
C
      IF (IV(SWITCH) .EQ. 0) GO TO 360
         IV(H) = -IABS(IV(H))
         IV(SUSED) = IV(SUSED) + 2
         CALL VCOPY(NVSAVE, V, V(VSAVE1))
 360  IF (IV(RESTOR) .EQ. 0) GO TO 390
         RSAVE1 = IV(RSAVE)
         CALL VCOPY(N, R, V(RSAVE1))
 390  L = IV(IRC) - 4
      STPMOD = IV(MODEL)
      IF (L .GT. 0) GO TO (410,440,450,450,450,450,450,450,640,570), L
C
C  ***  DECIDE WHETHER TO CHANGE MODELS  ***
C
      E = V(PREDUC) - V(FDIF)
      SSTEP = IV(LKY)
      S1 = IV(S)
      CALL SLVMUL(P, V(SSTEP), V(S1), V(STEP1))
      STTSST = HALF * DOTPRD(P, V(STEP1), V(SSTEP))
      IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
      IF (ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 400
C
C     ***  SWITCH MODELS  ***
C
         IV(MODEL) = 3 - IV(MODEL)
         IF (IV(MODEL) .EQ. 1) IV(KAGQT) = -1
         IF (IV(MODEL) .EQ. 2 .AND. IV(KALM) .GT. 0) IV(KALM) = 0
         IF (-2 .LT. L) GO TO 480
              IV(H) = -IABS(IV(H))
              IV(SUSED) = IV(SUSED) + 2
              CALL VCOPY(NVSAVE, V(VSAVE1), V)
              GO TO 420
C
 400  IF (-3 .LT. L) GO TO 480
C
C     ***  RECOMPUTE STEP WITH DECREASED RADIUS  ***
C
         V(RADIUS) = V(RADFAC) * V(DSTNRM)
         GO TO 190
C
C  ***  RECOMPUTE STEP, SAVING V VALUES AND R IF NECESSARY  ***
C
 410  V(RADIUS) = V(RADFAC) * V(DSTNRM)
 420  IF (V(F) .GE. V(F0)) GO TO 190
      RSAVE1 = IV(RSAVE)
      CALL VCOPY(N, V(RSAVE1), R)
      GO TO 190
C
C  ***  COMPUTE STEP OF LENGTH V(LMAX0) FOR SINGULAR CONVERGENCE TEST
C
 440  V(RADIUS) = V(LMAX0)
      GO TO 210
C
C  ***  CONVERGENCE OR FALSE CONVERGENCE  ***
C
 450  IV(CNVCOD) = L
      IF (V(F) .GE. V(F0)) GO TO 700
         IF (IV(XIRC) .EQ. 14) GO TO 700
              IV(XIRC) = 14
C
C. . . . . . . . . . . .  PROCESS ACCEPTABLE STEP  . . . . . . . . . . .
C
 480  IV(COVMAT) = 0
C
C  ***  SET  LKY = (J(X0)**T) * R(X)  ***
C
      LKY1 = IV(LKY)
      IF (IV(KALM) .GE. 0) GO TO 500
C
C     ***  JACOBIAN HAS NOT BEEN MODIFIED  ***
C
         DO 490 I = 1, P
              V(LKY1) = DOTPRD(N, J(1,I), R)
              LKY1 = LKY1 + 1
 490          CONTINUE
         GO TO 510
C
C  ***  QRFACT HAS BEEN APPLIED TO J.  STORE COPY OF R IN QTR AND  ***
C  ***  APPLY Q TO IT.                                             ***
C
 500  QTR1 = IV(QTR)
      CALL VCOPY(N, V(QTR1), R)
      CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR))
C
C  ***  MULTIPLY TOP P-VECTOR IN QTR BY PERMUTED UPPER TRIANGLE    ***
C  ***  STORED BY QRFACT IN J AND RD.                              ***
C
      RD1 = IV(RD)
      TEMP1 = IV(STLSTG)
      CALL RPTMUL(3, IV(IPIVOT), J, NN, P, V(RD1), V(QTR1), V(LKY1),
     1            V(TEMP1))
C
C  ***  SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS  ***
C
 510  IF (IV(IRC) .NE. 3) GO TO 560
         STEP1 = IV(STEP)
         TEMP1 = IV(STLSTG)
         TEMP2 = IV(X0)
C
C     ***  SET  TEMP1 = HESSIAN * STEP  FOR USE IN GRADIENT TESTS  ***
C
         IF (STPMOD .EQ. 2) GO TO 530
C
C        ***  STEP COMPUTED USING GAUSS-NEWTON MODEL  ***
C        ***  -- QRFACT HAS BEEN APPLIED TO J         ***
C
              RD1 = IV(RD)
              CALL RPTMUL(2, IV(IPIVOT), J, NN, P, V(RD1),
     1                    V(STEP1), V(TEMP1), V(TEMP2))
              GO TO 560
C
C     ***  STEP COMPUTED USING AUGMENTED MODEL  ***
C
 530     H1 = IV(H)
         K = TEMP2
         DO 540 I = 1, P
              V(K) = D(I) * V(STEP1)
              K = K + 1
              STEP1 = STEP1 + 1
 540          CONTINUE
         CALL SLVMUL(P, V(TEMP1), V(H1), V(TEMP2))
         DO 550 I = 1, P
              V(TEMP1) = D(I) * V(TEMP1)
              TEMP1 = TEMP1 + 1
 550          CONTINUE
C
C  ***  SAVE OLD GRADIENT AND COMPUTE NEW ONE  ***
C
 560  IV(NGCALL) = IV(NGCALL) + 1
      G1 = IV(G)
      G01 = IV(W)
      CALL VCOPY(P, V(G01), V(G1))
      IV(1) = 2
      GO TO 999
C
C  ***  INITIALIZATIONS -- G0 = G - G0, ETC.  ***
C
 570  G01 = IV(W)
      G1 = IV(G)
      CALL VAXPY(P, V(G01), NEGONE, V(G01), V(G1))
      STEP1 = IV(STEP)
      TEMP1 = IV(STLSTG)
      TEMP2 = IV(X0)
      IF (IV(IRC) .NE. 3) GO TO 600
C
C  ***  SET V(RADFAC) BY GRADIENT TESTS  ***
C
C     ***  SET  TEMP1 = D**-1 * (HESSIAN * STEP  +  (G(X0) - G(X)))  ***
C
         K = TEMP1
         L = G01
         DO 580 I = 1, P
              V(K) = (V(K) - V(L)) / D(I)
              K = K + 1
              L = L + 1
 580          CONTINUE
C
C        ***  DO GRADIENT TESTS  ***
C
         IF (V2NORM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))  GO TO 590
              IF (DOTPRD(P, V(G1), V(STEP1))
     1                  .GE. V(GTSTEP) * V(TUNER5))  GO TO 600
 590               V(RADFAC) = V(INCFAC)
C
C  ***  FINISH COMPUTING LKY = ((J(X) - J(X0))**T) * R  ***
C
C     ***  CURRENTLY LKY = (J(X0)**T) * R  ***
C
 600  LKY1 = IV(LKY)
      CALL VAXPY(P, V(LKY1), NEGONE, V(LKY1), V(G1))
C
C  ***  DETERMINE SIZING FACTOR V(SIZE)  ***
C
C     ***  SET TEMP1 = S * STEP  ***
      S1 = IV(S)
      CALL SLVMUL(P, V(TEMP1), V(S1), V(STEP1))
C
      T1 = ABS(DOTPRD(P, V(STEP1), V(TEMP1)))
      T = ABS(DOTPRD(P, V(STEP1), V(LKY1)))
      V(SIZE) = ONE
      IF (T .LT. T1) V(SIZE) = T / T1
C
C  ***  UPDATE S  ***
C
      CALL SLUPDT(V(S1), V(COSMIN), P, V(SIZE), V(STEP1), V(TEMP1),
     1            V(TEMP2), V(G01), V(WSCALE), V(LKY1))
      IV(1) = 2
      GO TO 150
C
C. . . . . . . . . . . . . .  MISC. DETAILS  . . . . . . . . . . . . . .
C
C  ***  BAD PARAMETERS TO ASSESS  ***
C
 640  IV(1) = 14
      GO TO 900
C
C  ***  CONVERGENCE OBTAINED -- COMPUTE COVARIANCE MATRIX IF DESIRED ***
C
 700  IF (IV(COVREQ) .EQ. 0 .AND. IV(COVPRT) .EQ. 0) GO TO 760
      IF (IV(COVMAT) .NE. 0) GO TO 760
      IF (IV(CNVCOD) .GE. 7) GO TO 760
      IV(MODE) = 0
 710  CALL COVCLC(I, D, IV, J, N, NN, P, R, V, X)
      GO TO (720, 720, 740, 750), I
 720  IV(NFCOV) = IV(NFCOV) + 1
      IV(NFCALL) = IV(NFCALL) + 1
      IV(RESTOR) = I
      IV(1) = 1
      GO TO 999
C
 730  IF (IV(RESTOR) .EQ. 1 .OR. IV(TOOBIG) .NE. 0) GO TO 710
      IV(NFGCAL) = IV(NFCALL)
 740  IV(NGCOV) = IV(NGCOV) + 1
      IV(NGCALL) = IV(NGCALL) + 1
      IV(1) = 2
      GO TO 999
C
 750  IV(MODE) = 0
      IF (IV(NITER) .EQ. 0) IV(MODE) = -1
C
 760  IV(1) = IV(CNVCOD)
      IV(CNVCOD) = 0
C
C  ***  PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS  ***
C
 900  CALL ITSMRY(D, IV, P, V, X)
C
 999  RETURN
C
C  ***  LAST CARD OF NL2ITR FOLLOWS  ***
      END
      SUBROUTINE ASSESS (D, IV, P, STEP, STLSTG, V, X, X0)              ASS00010
C
C  ***  ASSESS CANDIDATE STEP (NL2SOL VERSION 2.2)  ***
C
      INTEGER P, IV(13)
      REAL D(P), STEP(P), STLSTG(P), V(35), X(P), X0(P)
C
C  ***  PURPOSE  ***
C
C        THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
C     ROUTINE TO ASSESS THE NEXT CANDIDATE STEP.  IT MAY RECOMMEND ONE
C     OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
C     PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
C     TO CONVERGENCE OR FALSE CONVERGENCE.  SEE THE RETURN CODE LISTING
C     BELOW.
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C     IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF IV VALUES REFERENCED.
C      D (IN)  SCALE VECTOR USED IN COMPUTING V(RELDX) -- SEE BELOW.
C      P (IN)  NUMBER OF PARAMETERS BEING OPTIMIZED.
C   STEP (I/O) ON INPUT, STEP IS THE STEP TO BE ASSESSED.  IT IS UN-
C             CHANGED ON OUTPUT UNLESS A PREVIOUS STEP ACHIEVED A
C             BETTER OBJECTIVE FUNCTION REDUCTION, IN WHICH CASE STLSTG
C             WILL HAVE BEEN COPIED TO STEP.
C STLSTG (I/O) WHEN ASSESS RECOMMENDS RECOMPUTING STEP EVEN THOUGH THE
C             CURRENT (OR A PREVIOUS) STEP YIELDS AN OBJECTIVE FUNC-
C             TION DECREASE, IT SAVES IN STLSTG THE STEP THAT GAVE THE
C             BEST FUNCTION REDUCTION SEEN SO FAR (IN THE CURRENT ITERA-
C             TION).  IF THE RECOMPUTED STEP YIELDS A LARGER FUNCTION
C             VALUE, THEN STEP IS RESTORED FROM STLSTG AND
C             X = X0 + STEP IS RECOMPUTED.
C      V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF V VALUES REFERENCED.
C      X (I/O) ON INPUT, X = X0 + STEP IS THE POINT AT WHICH THE OBJEC-
C             TIVE FUNCTION HAS JUST BEEN EVALUATED.  IF AN EARLIER
C             STEP YIELDED A BIGGER FUNCTION DECREASE, THEN X IS
C             RESTORED TO THE CORRESPONDING EARLIER VALUE.  OTHERWISE,
C             IF THE CURRENT STEP DOES NOT GIVE ANY FUNCTION DECREASE,
C             THEN X IS RESTORED TO X0.
C     X0 (IN)  INITIAL OBJECTIVE FUNCTION PARAMETER VECTOR (AT THE
C             START OF THE CURRENT ITERATION).
C
C  ***  IV VALUES REFERENCED  ***
C
C    IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
C             IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
C             SET WHEN STEP IS DEFINITELY TO BE ACCEPTED).  ON INPUT
C             AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
C             UNCHANGED SINCE THE PREVIOUS RETURN OF ASSESS.
C                ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
C             FOLLOWING VALUES...
C                  1 = SWITCH MODELS OR TRY SMALLER STEP.
C                  2 = SWITCH MODELS OR ACCEPT STEP.
C                  3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
C                       TESTS.
C                  4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
C                  5 = RECOMPUTE STEP (USING THE SAME MODEL).
C                  6 = RECOMPUTE STEP WITH RADIUS = V(LMAX0) BUT DO NOT
C                       EVAULATE THE OBJECTIVE FUNCTION.
C                  7 = X-CONVERGENCE (SEE V(XCTOL)).
C                  8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
C                  9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
C                 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
C                 11 = SINGULAR CONVERGENCE (SEE V(LMAX0)).
C                 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
C                 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
C             RETURN CODE I HAS PRECDENCE OVER I+1 FOR I = 9, 10, 11.
C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
C  IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
C             THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
C             IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
C             THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
C IV(NFCALL) (IN)  INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
C             FUNCTION REDUCTION THIS ITERATION.  IV(NFGCAL) REMAINS
C             UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
C             OF DECREASES) SO FAR THIS ITERATION.
C IV(RESTOR) (OUT) SET TO 0 UNLESS X AND V(F) HAVE BEEN RESTORED, IN
C             WHICH CASE ASSESS SETS IV(RESTOR) = 1.
C  IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
C             CURRENT ITERATION.
C IV(STGLIM) (IN)  MAXIMUM NUMBER OF MODELS TO CONSIDER.
C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
C             GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
C             IN WHICH CASE ASSESS SETS IV(SWITCH) = 1.
C IV(TOOBIG) (IN)  IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED
C             OVERFLOW).
C   IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
C             CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
C
C  ***  V VALUES REFERENCED  ***
C
C V(AFCTOL) (IN)  ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
C             THAN V(AFCTOL), THEN ASSESS RETURNS WITH IV(IRC) = 10.
C V(DECFAC) (IN)  FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
C             NONZERO.
C V(DSTNRM) (IN)  THE 2-NORM OF D*STEP.
C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
C   V(DST0) (IN)  THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
C             I.E., FOR V(NREDUC) .GE. 0).
C      V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
C             TION VALUE AT X.  IF X IS RESTORED TO A PREVIOUS VALUE,
C             THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
C   V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
C             VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
C             DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
C     V(F0) (IN)  OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
C V(GTSTEP) (IN)  INNER PRODUCT BETWEEN STEP AND GRADIENT.
C V(INCFAC) (IN)  MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
C  V(LMAX0) (IN)  MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
C             IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
C             WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, 9,
C             OR 10 DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAX0), AND IF
C             V(PREDUC) .LE. V(RFCTOL) * ABS(V(F0)), THEN ASSESS RE-
C             TURNS WITH IV(IRC) = 11.  IF SO DOING APPEARS WORTHWHILE,
C             THEN ASSESS REPEATS THIS TEST WITH V(PREDUC) COMPUTED FOR
C             A STEP OF LENGTH V(LMAX0) (BY A RETURN WITH IV(IRC) = 6).
C V(NREDUC) (I/O)  FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             NEWTON STEP.  IF ASSESS IS CALLED WITH IV(IRC) = 6, I.E.,
C             IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAX0) FOR
C             USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS
C             SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             CURRENT STEP.
C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
C             WHICH SHOULD BE V(RADFAC)*DST, WHERE  DST  IS EITHER THE
C             OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
C             DIAG(NEWD)*STEP  FOR THE OUTPUT VALUE OF STEP AND THE
C             UPDATED VERSION, NEWD, OF THE SCALE VECTOR D.  FOR
C             IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
C V(RDFCMN) (IN)  MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
C             VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
C V(RDFCMX) (IN)  MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
C  V(RELDX) (OUT) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
C             BY FUNCTION  RELDST  AS
C                 MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
C                    MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
C             IF AN ACCEPTABLE STEP IS RETURNED, THEN V(RELDX) IS COM-
C             PUTED USING THE OUTPUT (POSSIBLY RESTORED) VALUES OF X
C             AND STEP.  OTHERWISE IT IS COMPUTED USING THE INPUT
C             VALUES.
C V(RFCTOL) (IN)  RELATIVE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
C             DICTED AND  V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)),  THEN
C             ASSESS RETURNS WITH IV(IRC) = 8 OR 9.  SEE ALSO V(LMAX0).
C V(STPPAR) (IN)  MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
C V(TUNER1) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS MUCH LESS THAN EXPECTED.  SUGGESTED
C             VALUE = 0.1.
C V(TUNER2) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP.  SUGGESTED
C             VALUE = 10**-4.
C V(TUNER3) (IN)  TUNING CONSTANT USED TO DECIDE IF THE RADIUS
C             SHOULD BE INCREASED.  SUGGESTED VALUE = 0.75.
C  V(XCTOL) (IN)  X-CONVERGENCE CRITERION.  IF STEP IS A NEWTON STEP
C             (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
C             AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
C             ASSESS RETURNS IV(IRC) = 7 OR 9.
C  V(XFTOL) (IN)  FALSE CONVERGENCE TOLERANCE.  IF STEP GAVE NO OR ONLY
C             A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
C             THEN ASSESS RETURNS WITH IV(IRC) = 12.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C        THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
C     LEAST-SQUARES) PACKAGE.  IT MAY BE USED IN ANY UNCONSTRAINED
C     MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
C     OR LEVENBERG-MARQUARDT STEPS.
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
C     SWITCHING STRATEGIES.  WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
C     ASSESS IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
C
C  ***  USAGE NOTES  ***
C
C        ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
C     STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
C     V(PREDUC) NEED HAVE BEEN INITIALIZED.  BETWEEN CALLS, NO I/O
C     VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
C     ANCES SHOULD BE CHANGED.
C        AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
C     CHANGE THE STOPPING TOLERANCES AND CALL ASSESS AGAIN, IN WHICH
C     CASE THE STOPPING TESTS WILL BE REPEATED.
C
C  ***  REFERENCES  ***
C
C     (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981),
C        AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
C        ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3.
C
C     (2) POWELL, M.J.D. (1970)  A FORTRAN SUBROUTINE FOR SOLVING
C        SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
C        METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
C        P. RABINOWITZ, GORDON AND BREACH, LONDON.
C
C  ***  HISTORY  ***
C
C        JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
C     IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
C        DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
C     PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
C     PRESENT FORM (FALL 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C------------------------  EXTERNAL QUANTITIES  ------------------------
C
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL RELDST, VCOPY
      REAL RELDST
C
C VCOPY.... COPIES ONE VECTOR TO ANOTHER.
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      REAL ABS, AMAX1
C/
C  ***  NO COMMON BLOCKS  ***
C
C--------------------------  LOCAL VARIABLES  --------------------------
C
      LOGICAL GOODX
      INTEGER I, NFC
      REAL EMAX, GTS, HALF, ONE, RELDX1, RFAC1, TWO, XMAX,
     1                 ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
     1        GTSLST, GTSTEP, INCFAC, IRC, LMAX0, MLSTGD, MODEL, NFCALL,
     2        NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
     3        RDFCMX, RELDX, RESTOR, RFCTOL, STAGE, STGLIM, STPPAR,
     4        SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, XFTOL,
     5        XIRC
C
C  ***  DATA INITIALIZATIONS  ***
C
C/6
      DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0)
C/
C
C/6
      DATA IRC/3/, MLSTGD/4/, MODEL/5/, NFCALL/6/,
     1     NFGCAL/7/, RADINC/8/, RESTOR/9/, STAGE/10/,
     2     STGLIM/11/, SWITCH/12/, TOOBIG/2/, XIRC/13/
C/7
C     PARAMETER (IRC=3, MLSTGD=4, MODEL=5, NFCALL=6,
C    1     NFGCAL=7, RADINC=8, RESTOR=9, STAGE=10,
C    2     STGLIM=11, SWITCH=12, TOOBIG=2, XIRC=13)
C/
C/6
      DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/,
     1     DSTSAV/18/, F/10/, FDIF/11/, FLSTGD/12/, F0/13/,
     2     GTSLST/14/, GTSTEP/4/, INCFAC/23/,
     3     LMAX0/35/, NREDUC/6/, PLSTGD/15/, PREDUC/7/,
     4     RADFAC/16/, RDFCMN/24/, RDFCMX/25/,
     5     RELDX/17/, RFCTOL/32/, STPPAR/5/, TUNER1/26/,
     6     TUNER2/27/, TUNER3/28/, XCTOL/33/, XFTOL/34/
C/7
C     PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3,
C    1     DSTSAV=18, F=10, FDIF=11, FLSTGD=12, F0=13,
C    2     GTSLST=14, GTSTEP=4, INCFAC=23,
C    3     LMAX0=35, NREDUC=6, PLSTGD=15, PREDUC=7,
C    4     RADFAC=16, RDFCMN=24, RDFCMX=25,
C    5     RELDX=17, RFCTOL=32, STPPAR=5, TUNER1=26,
C    6     TUNER2=27, TUNER3=28, XCTOL=33, XFTOL=34)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      NFC = IV(NFCALL)
      IV(SWITCH) = 0
      IV(RESTOR) = 0
      RFAC1 = ONE
      GOODX = .TRUE.
      I = IV(IRC)
      IF (I .GE. 1 .AND. I .LE. 12)
     1             GO TO (20,30,10,10,40,360,290,290,290,290,290,140), I
         IV(IRC) = 13
         GO TO 999
C
C  ***  INITIALIZE FOR NEW ITERATION  ***
C
 10   IV(STAGE) = 1
      IV(RADINC) = 0
      V(FLSTGD) = V(F0)
      IF (IV(TOOBIG) .EQ. 0) GO TO 90
         IV(STAGE) = -1
         IV(XIRC) = I
         GO TO 60
C
C  ***  STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS  ***
C  ***  FIRST DECIDE WHICH  ***
C
 20   IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
C        ***  OLD MODEL RETAINED, SMALLER RADIUS TRIED  ***
C        ***  DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION  ***
         IV(STAGE) = IV(STGLIM)
         IV(RADINC) = -1
         GO TO 90
C
C  ***  A NEW MODEL IS BEING TRIED.  DECIDE WHETHER TO KEEP IT.  ***
C
 30   IV(STAGE) = IV(STAGE) + 1
C
C     ***  NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH  ***
C     ***  THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP.     ***
C
 40   IF (IV(STAGE) .GT. 0) GO TO 50
C
C        ***  STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG.  ***
C
         IF (IV(TOOBIG) .NE. 0) GO TO 60
C
C        ***  RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF.  ***
C
         IV(STAGE) = -IV(STAGE)
         I = IV(XIRC)
         GO TO (20, 30, 90, 90, 70), I
C
 50   IF (IV(TOOBIG) .EQ. 0) GO TO 70
C
C  ***  HANDLE OVERSIZE STEP  ***
C
      IF (IV(RADINC) .GT. 0) GO TO 80
         IV(STAGE) = -IV(STAGE)
         IV(XIRC) = IV(IRC)
C
 60      V(RADFAC) = V(DECFAC)
         IV(RADINC) = IV(RADINC) - 1
         IV(IRC) = 5
         GO TO 999
C
 70   IF (V(F) .LT. V(FLSTGD)) GO TO 90
C
C     *** THE NEW STEP IS A LOSER.  RESTORE OLD MODEL.  ***
C
      IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
         IV(MODEL) = IV(MLSTGD)
         IV(SWITCH) = 1
C
C     ***  RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
C
 80   IF (V(FLSTGD) .GE. V(F0)) GO TO 90
         IV(RESTOR) = 1
         V(F) = V(FLSTGD)
         V(PREDUC) = V(PLSTGD)
         V(GTSTEP) = V(GTSLST)
         IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
         V(DSTNRM) = V(DSTSAV)
         NFC = IV(NFGCAL)
         GOODX = .FALSE.
C
C
C  ***  COMPUTE RELATIVE CHANGE IN X BY CURRENT STEP  ***
C
 90   RELDX1 = RELDST(P, D, X, X0)
C
C  ***  RESTORE X AND STEP IF NECESSARY  ***
C
      IF (GOODX) GO TO 105
      DO 100 I = 1, P
         STEP(I) = STLSTG(I)
         X(I) = X0(I) + STLSTG(I)
 100     CONTINUE
C
 105  V(FDIF) = V(F0) - V(F)
      IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 120
C
C        ***  NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
C        ***  -- SO TRY NEW MODEL OR SMALLER RADIUS
C
         V(RELDX) = RELDX1
         IF (V(F) .LT. V(F0)) GO TO 110
              IV(MLSTGD) = IV(MODEL)
              V(FLSTGD) = V(F)
              V(F) = V(F0)
              CALL VCOPY(P, X, X0)
              IV(RESTOR) = 1
              GO TO 115
 110     IV(NFGCAL) = NFC
 115     IV(IRC) = 1
         IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 130
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) - 1
              GO TO 130
C
C  ***  NONTRIVIAL FUNCTION DECREASE ACHIEVED  ***
C
 120  IV(NFGCAL) = NFC
      RFAC1 = ONE
      IF (GOODX) V(RELDX) = RELDX1
      V(DSTSAV) = V(DSTNRM)
      IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 200
C
C  ***  DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
C  ***  OR ACCEPT STEP WITH DECREASED RADIUS.
C
      IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 125
C        ***  CONSIDER SWITCHING MODELS  ***
         IV(IRC) = 2
         GO TO 130
C
C     ***  ACCEPT STEP WITH DECREASED RADIUS  ***
C
 125  IV(IRC) = 4
C
C  ***  SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR  ***
C
 130  IV(XIRC) = IV(IRC)
      EMAX = V(GTSTEP) + V(FDIF)
      V(RADFAC) = HALF * RFAC1
      IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * AMAX1(V(RDFCMN),
     1                                           HALF * V(GTSTEP)/EMAX)
C
C  ***  DO FALSE CONVERGENCE TEST  ***
C
 140  IF (V(RELDX) .LE. V(XFTOL)) GO TO 160
         IV(IRC) = IV(XIRC)
         IF (V(F) .LT. V(F0)) GO TO 230
              GO TO 300
C
 160  IV(IRC) = 12
      GO TO 310
C
C  ***  HANDLE GOOD FUNCTION DECREASE  ***
C
 200  IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 260
C
C     ***  INCREASING RADIUS LOOKS WORTHWHILE.  SEE IF WE JUST
C     ***  RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
C     ***  AFTER RECOMPUTING IT WITH A LARGER RADIUS.
C
      IF (IV(RADINC) .LT. 0) GO TO 260
      IF (IV(RESTOR) .EQ. 1) GO TO 260
C
C        ***  WE DID NOT.  TRY A LONGER STEP UNLESS THIS WAS A NEWTON
C        ***  STEP.
C
         V(RADFAC) = V(RDFCMX)
         GTS = V(GTSTEP)
         IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
     1            V(RADFAC) = AMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
         IV(IRC) = 4
         IF (V(STPPAR) .EQ. ZERO) GO TO 300
C             ***  STEP WAS NOT A NEWTON STEP.  RECOMPUTE IT WITH
C             ***  A LARGER RADIUS.
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) + 1
C
C  ***  SAVE VALUES CORRESPONDING TO GOOD STEP  ***
C
 230  V(FLSTGD) = V(F)
      IV(MLSTGD) = IV(MODEL)
      CALL VCOPY(P, STLSTG, STEP)
      V(DSTSAV) = V(DSTNRM)
      IV(NFGCAL) = NFC
      V(PLSTGD) = V(PREDUC)
      V(GTSLST) = V(GTSTEP)
      GO TO 300
C
C  ***  ACCEPT STEP WITH RADIUS UNCHANGED  ***
C
 260  V(RADFAC) = ONE
      IV(IRC) = 3
      GO TO 300
C
C  ***  COME HERE FOR A RESTART AFTER CONVERGENCE  ***
C
 290  IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .GE. ZERO) GO TO 310
         IV(IRC) = 12
         GO TO 310
C
C  ***  PERFORM CONVERGENCE TESTS  ***
C
 300  IV(XIRC) = IV(IRC)
 310  IF (ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
      IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
      EMAX = V(RFCTOL) * ABS(V(F0))
      IF (V(DSTNRM) .GT. V(LMAX0) .AND. V(PREDUC) .LE. EMAX)
     1                       IV(IRC) = 11
      IF (V(DST0) .LT. ZERO) GO TO 320
      I = 0
      IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
     1    (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO))  I = 2
      IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)
     1                        .AND. GOODX)                  I = I + 1
      IF (I .GT. 0) IV(IRC) = I + 6
C
C  ***  CONSIDER RECOMPUTING STEP OF LENGTH V(LMAX0) FOR SINGULAR
C  ***  CONVERGENCE TEST.
C
 320  IF (IABS(IV(IRC)-3) .GT. 2 .AND. IV(IRC) .NE. 12) GO TO 999
      IF (V(DSTNRM) .GT. V(LMAX0)) GO TO 330
         IF (V(PREDUC) .GE. EMAX) GO TO 999
              IF (V(DST0) .LE. ZERO) GO TO 340
                   IF (HALF * V(DST0) .LE. V(LMAX0)) GO TO 999
                        GO TO 340
 330  IF (HALF * V(DSTNRM) .LE. V(LMAX0)) GO TO 999
      XMAX = V(LMAX0) / V(DSTNRM)
      IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAX) GO TO 999
 340  IF (V(NREDUC) .LT. ZERO) GO TO 370
C
C  ***  RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST  ***
C
      V(GTSLST) = V(GTSTEP)
      V(DSTSAV) = V(DSTNRM)
      IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
      V(PLSTGD) = V(PREDUC)
      IV(IRC) = 6
      CALL VCOPY(P, STLSTG, STEP)
      GO TO 999
C
C  ***  PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC)  ***
C
 360  V(GTSTEP) = V(GTSLST)
      V(DSTNRM) = ABS(V(DSTSAV))
      CALL VCOPY(P, STEP, STLSTG)
      IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
      V(NREDUC) = -V(PREDUC)
      V(PREDUC) = V(PLSTGD)
 370  IF (-V(NREDUC) .LE. V(RFCTOL) * ABS(V(F0))) IV(IRC) = 11
C
 999  RETURN
C
C  ***  LAST CARD OF ASSESS FOLLOWS  ***
      END
      SUBROUTINE COVCLC(COVIRC, D, IV, J, N, NN, P, R, V, X)            COV00010
C
C  ***  COMPUTE COVARIANCE MATRIX FOR NL2ITR (NL2SOL VERSION 2.2)  ***
C
C  ***  LET K = IABS(IV(COVREQ).  FOR K .LE. 2, A FINITE-DIFFERENCE
C  ***  HESSIAN H IS COMPUTED (USING FUNC. AND GRAD. VALUES IF
C  ***  IV(COVREQ) IS NONNEGATIVE, AND USING ONLY FUNC. VALUES IF
C  ***  IV(COVREQ) IS NEGATIVE).  FOR SCALE = 2*F(X) / MAX(1, N-P),
C  ***  WHERE 2*F(X) IS THE RESIDUAL SUM OF SQUARES, COVCLC COMPUTES...
C  ***             K = 0 OR 1...  SCALE * H**-1 * (J**T * J) * H**-1.
C  ***             K = 2...  SCALE * H**-1.
C  ***             K .GE. 3...  SCALE * (J**T * J)**-1.
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER COVIRC, IV(1), N, NN, P
      REAL D(P), J(NN,P), R(N), V(1), X(P)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
      LOGICAL HAVEJ
      INTEGER COV, GP, GSAVE1, G1, HC, HMI, HPI, HPM, I, IPIVI, IPIVK,
     1        IP1, IRC, K, KIND, KL, L, M, MM1, MM1O2, PP1O2, QTR1,
     2        RD1, STPI, STPM, STP0, WL, W0, W1
      REAL DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS, MAX0
      REAL ABS, AMAX1, FLOAT, SQRT
C/
C  ***  EXTERNAL SUBROUTINES  ***
C
      EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRT, LTSQAR, QRFACT,
     1         VCOPY, VSCOPY
C
C LINVRT... INVERT LOWER TRIANGULAR MATRIX.
C LITVMU... APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C LSQRT.... COMPUTE CHOLESKY FACTOR OF (LOWER TRINAG. OF) A SYM. MATRIX.
C LTSQAR... GIVEN LOWER TRIANG. MATRIX L, COMPUTE (L**T)*L.
C QRFACT... COMPUTE QR DECOMPOSITION OF A MATRIX.
C VCOPY.... COPY ONE VECTOR TO ANOTHER.
C VSCOPY... SET ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER COVMAT, COVREQ, DELTA, DELTA0, DLTFDC, F, FX, G, H, IERR,
     1        IPIVOT, IPIV0, KAGQT, KALM, LMAT, MODE, NFGCAL, QTR,
     2        RD, RSAVE, SAVEI, SWITCH, TOOBIG, W, XMSAVE
C
C/6
      DATA HALF/0.5E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, TWO/2.E+0/,
     1     ZERO/0.E+0/
C/7
C     PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0,
C    1     ZERO=0.D+0)
C/
C
C/6
      DATA COVMAT/26/, COVREQ/15/, DELTA/50/, DELTA0/44/,
     1     DLTFDC/40/, F/10/, FX/46/, G/28/, H/44/, IERR/32/,
     2     IPIVOT/61/, IPIV0/60/, KAGQT/35/, KALM/36/,
     3     LMAT/58/, MODE/38/, NFGCAL/7/, QTR/49/,
     4     RD/51/, RSAVE/52/, SAVEI/54/, SWITCH/12/,
     5     TOOBIG/2/, W/59/, XMSAVE/49/
C/7
C     PARAMETER (COVMAT=26, COVREQ=15, DELTA=50, DELTA0=44,
C    1     DLTFDC=40, F=10, FX=46, G=28, H=44, IERR=32,
C    2     IPIVOT=61, IPIV0=60, KAGQT=35, KALM=36,
C    3     LMAT=58, MODE=38, NFGCAL=7, QTR=49,
C    4     RD=51, RSAVE=52, SAVEI=54, SWITCH=12,
C    5     TOOBIG=2, W=59, XMSAVE=49)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      COVIRC = 4
      KIND = IV(COVREQ)
      M = IV(MODE)
      IF (M .GT. 0) GO TO 10
         IV(KAGQT) = -1
         IF (IV(KALM) .GT. 0) IV(KALM) = 0
         IF (IABS(KIND) .GE. 3) GO TO 300
         V(FX) = V(F)
         K = IV(RSAVE)
         CALL VCOPY(N, V(K), R)
 10   IF (M .GT. P) GO TO 200
      IF (KIND .LT. 0) GO TO 100
C
C  ***  COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
C  ***  GRADIENT VALUES.
C
      GSAVE1 = IV(W) + P
      G1 = IV(G)
      IF (M .GT. 0) GO TO 15
C        ***  FIRST CALL ON COVCLC.  SET GSAVE = G, TAKE FIRST STEP  ***
         CALL VCOPY(P, V(GSAVE1), V(G1))
         IV(SWITCH) = IV(NFGCAL)
         GO TO 80
C
 15   DEL = V(DELTA)
      X(M) = V(XMSAVE)
      IF (IV(TOOBIG) .EQ. 0) GO TO 30
C
C     ***  HANDLE OVERSIZE V(DELTA)  ***
C
         IF (DEL*X(M) .GT. ZERO) GO TO 20
C             ***  WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT  ***
              IV(COVMAT) = -2
              GO TO 190
C
C        ***  TRY SHRINKING V(DELTA)  ***
 20      DEL = NEGPT5 * DEL
         GO TO 90
C
 30   COV = IV(LMAT)
      GP = G1 + P - 1
C
C  ***  SET  G = (G - GSAVE)/DEL  ***
C
      DO 40 I = G1, GP
         V(I) = (V(I) - V(GSAVE1)) / DEL
         GSAVE1 = GSAVE1 + 1
 40      CONTINUE
C
C  ***  ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX  ***
C
      K = COV + M*(M-1)/2
      L = K + M - 2
      IF ( M .EQ. 1) GO TO 60
C
C  ***  SET  H(I,M) = 0.5 * (H(I,M) + G(I))  FOR I = 1 TO M-1  ***
C
      DO 50 I = K, L
         V(I) = HALF * (V(I) + V(G1))
         G1 = G1 + 1
 50      CONTINUE
C
C  ***  ADD  H(I,M) = G(I)  FOR I = M TO P  ***
C
 60   L = L + 1
      DO 70 I = M, P
         V(L) = V(G1)
         L = L + I
         G1 = G1 + 1
 70      CONTINUE
C
 80   M = M + 1
      IV(MODE) = M
      IF (M .GT. P) GO TO 190
C
C  ***  CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE  ***
C
      DEL = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M)))
      IF (X(M) .LT. ZERO) DEL = -DEL
      V(XMSAVE) = X(M)
 90   X(M) = X(M) + DEL
      V(DELTA) = DEL
      COVIRC = 2
      GO TO 999
C
C  ***  COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
C
 100  STP0 = IV(W) + P - 1
      MM1 = M - 1
      MM1O2 = M*MM1/2
      IF (M .GT. 0) GO TO 105
C        ***  FIRST CALL ON COVCLC.  ***
         IV(SAVEI) = 0
         GO TO 180
C
 105  I = IV(SAVEI)
      IF (I .GT. 0) GO TO 160
      IF (IV(TOOBIG) .EQ. 0) GO TO 120
C
C     ***  HANDLE OVERSIZE STEP  ***
C
         STPM = STP0 + M
         DEL = V(STPM)
         IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 110
C             ***  WE ALREADY TRIED SHRINKING THE STEP, SO QUIT  ***
              IV(COVMAT) = -2
              GO TO 999
C
C        ***  TRY SHRINKING THE STEP  ***
 110     DEL = NEGPT5 * DEL
         X(M) = X(XMSAVE) + DEL
         V(STPM) = DEL
         COVIRC = 1
         GO TO 999
C
C  ***  SAVE F(X + STP(M)*E(M)) IN H(P,M)  ***
C
 120  PP1O2 = P * (P-1) / 2
      COV = IV(LMAT)
      HPM = COV + PP1O2 + MM1
      V(HPM) = V(F)
C
C  ***  START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H.  ***
C
      HMI = COV + MM1O2
      IF (MM1 .EQ. 0) GO TO 140
      HPI = COV + PP1O2
      DO 130 I = 1, MM1
         V(HMI) = V(FX) - (V(F) + V(HPI))
         HMI = HMI + 1
         HPI = HPI + 1
 130     CONTINUE
 140  V(HMI) = V(F) - TWO*V(FX)
C
C  ***  COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H.  ***
C
      I = 1
C
 150  IV(SAVEI) = I
      STPI = STP0 + I
      V(DELTA) = X(I)
      X(I) = X(I) + V(STPI)
      IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI)
      COVIRC = 1
      GO TO 999
C
 160  X(I) = V(DELTA)
      IF (IV(TOOBIG) .EQ. 0) GO TO 170
C        ***  PUNT IN THE EVENT OF AN OVERSIZE STEP  ***
         IV(COVMAT) = -2
         GO TO 999
C
C  ***  FINISH COMPUTING H(M,I)  ***
C
 170  STPI = STP0 + I
      HMI = COV + MM1O2 + I - 1
      STPM = STP0 + M
      V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
      I = I + 1
      IF (I .LE. M) GO TO 150
      IV(SAVEI) = 0
      X(M) = V(XMSAVE)
C
 180  M = M + 1
      IV(MODE) = M
      IF (M .GT. P) GO TO 190
C
C  ***  PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
C  ***  COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
C  ***  F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
C
      DEL = V(DLTFDC) * AMAX1(ONE/D(M), ABS(X(M)))
      IF (X(M) .LT. ZERO) DEL = -DEL
      V(XMSAVE) = X(M)
      X(M) = X(M) + DEL
      STPM = STP0 + M
      V(STPM) = DEL
      COVIRC = 1
      GO TO 999
C
C  ***  RESTORE R, V(F), ETC.  ***
C
 190  K = IV(RSAVE)
      CALL VCOPY(N, R, V(K))
      V(F) = V(FX)
      IF (KIND .LT. 0) GO TO 200
         IV(NFGCAL) = IV(SWITCH)
         QTR1 = IV(QTR)
         CALL VCOPY(N, V(QTR1), R)
         IF (IV(COVMAT) .LT. 0) GO TO 999
         COVIRC = 3
         GO TO 999
C
 200  COV = IV(LMAT)
C
C  ***  THE COMPLETE FINITE-DIFF. HESSIAN IS NOW STORED AT V(COV).   ***
C  ***  USE IT TO COMPUTE THE REQUESTED COVARIANCE MATRIX.           ***
C
C     ***  COMPUTE CHOLESKY FACTOR C OF H = C*(C**T)  ***
C     ***  AND STORE IT AT V(HC).  ***
C
      HC = COV
      IF (IABS(KIND) .EQ. 2) GO TO 210
         HC = IABS(IV(H))
         IV(H) = -HC
 210  CALL LSQRT(1, P, V(HC), V(COV), IRC)
      IV(COVMAT) = -1
      IF (IRC .NE. 0) GO TO 999
C
      W1 = IV(W) + P
      IF (IABS(KIND) .GT. 1) GO TO 350
C
C  ***  COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1  ***
C
      CALL VSCOPY(P*(P+1)/2, V(COV), ZERO)
      HAVEJ = IV(KALM) .EQ. (-1)
C     ***  HAVEJ = .TRUE. MEANS J IS IN ITS ORIGINAL FORM, WHILE
C     ***  HAVEJ = .FALSE. MEANS QRFACT HAS BEEN APPLIED TO J.
C
      M = P
      IF (HAVEJ) M = N
      W0 = W1 - 1
      RD1 = IV(RD)
      DO 290 I = 1, M
         IF (HAVEJ) GO TO 240
C
C        ***  SET W = IPIVOT * (ROW I OF R MATRIX FROM QRFACT).  ***
C
              CALL VSCOPY(P, V(W1), ZERO)
              IPIVI = IPIV0 + I
              L = W0 + IV(IPIVI)
              V(L) = V(RD1)
              RD1 = RD1 + 1
              IF (I .EQ. P) GO TO 260
              IP1 = I + 1
              DO 230 K = IP1, P
                   IPIVK = IPIV0 + K
                   L = W0 + IV(IPIVK)
                   V(L) = J(I,K)
 230               CONTINUE
              GO TO 260
C
C        ***  SET W = (ROW I OF J).  ***
C
 240     L = W0
         DO 250 K = 1, P
              L = L + 1
              V(L) = J(I,K)
 250          CONTINUE
C
C        ***  SET W = H**-1 * W.  ***
C
 260     CALL LIVMUL(P, V(W1), V(HC), V(W1))
         CALL LITVMU(P, V(W1), V(HC), V(W1))
C
C        ***  ADD  W * W**T  TO COVARIANCE MATRIX.  ***
C
         KL = COV
         DO 280 K = 1, P
              L = W0 + K
              WK = V(L)
              DO 270 L = 1, K
                   WL = W0 + L
                   V(KL) = V(KL)  +  WK * V(WL)
                   KL = KL + 1
 270               CONTINUE
 280          CONTINUE
 290     CONTINUE
      GO TO 380
C
C  ***  COVARIANCE = SCALE * (J**T * J)**-1.  ***
C
 300  RD1 = IV(RD)
      IF (IV(KALM) .NE. (-1)) GO TO 310
C
C        ***  APPLY QRFACT TO J  ***
C
         QTR1 = IV(QTR)
         CALL VCOPY(N, V(QTR1), R)
         W1 = IV(W) + P
         CALL QRFACT(NN, N, P, J, V(RD1), IV(IPIVOT), IV(IERR), 0,
     1               V(W1))
         IV(KALM) = -2
 310  IV(COVMAT) = -1
      IF (IV(IERR) .NE. 0) GO TO 999
      COV = IV(LMAT)
      HC = IABS(IV(H))
      IV(H) = -HC
C
C     ***  SET HC = (R MATRIX FROM QRFACT).  ***
C
      L = HC
      DO 340 I = 1, P
         IF (I .GT. 1) CALL VCOPY(I-1, V(L), J(1,I))
         L = L + I - 1
         V(L) = V(RD1)
         L = L + 1
         RD1 = RD1 + 1
 340     CONTINUE
C
C  ***  THE CHOLESKY FACTOR C OF THE UNSCALED INVERSE COVARIANCE MATRIX
C  ***  (OR PERMUTATION THEREOF) IS STORED AT V(HC).
C
C  ***  SET C = C**-1.
C
 350  CALL LINVRT(P, V(HC), V(HC))
C
C  ***  SET C = C**T * C.
C
      CALL LTSQAR(P, V(HC), V(HC))
C
      IF (HC .EQ. COV) GO TO 380
C
C     ***  C = PERMUTED, UNSCALED COVARIANCE.
C     ***  SET COV = IPIVOT * C * IPIVOT**T.
C
         DO 370 I = 1, P
              M = IPIV0 + I
              IPIVI = IV(M)
              KL = COV-1 + IPIVI*(IPIVI-1)/2
              DO 360 K = 1, I
                   M = IPIV0 + K
                   IPIVK = IV(M)
                   L = KL + IPIVK
                   IF (IPIVK .GT. IPIVI)
     1                       L = L + (IPIVK-IPIVI)*(IPIVK+IPIVI-3)/2
                   V(L) = V(HC)
                   HC = HC + 1
 360               CONTINUE
 370          CONTINUE
C
 380  IV(COVMAT) = COV
C
C  ***  APPLY SCALE FACTOR = (RESID. SUM OF SQUARES) / MAX(1,N-P).
C
      T = V(F) / (HALF * FLOAT(MAX0(1,N-P)))
      K = COV - 1 + P*(P+1)/2
      DO 390 I = COV, K
 390     V(I) = T * V(I)
C
 999  RETURN
C  ***  LAST CARD OF COVCLC FOLLOWS  ***
      END
      SUBROUTINE DFAULT(IV, V)                                          DFA00010
C
C  ***  SUPPLY NL2SOL (VERSION 2.2) DEFAULT VALUES TO IV AND V  ***
C
      INTEGER IV(25)
      REAL V(45)
C/+
      REAL AMAX1
C/
      EXTERNAL IMDCON, RMDCON
      INTEGER IMDCON
      REAL RMDCON
C
      REAL MACHEP, MEPCRT, ONE, SQTEPS, THREE
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER AFCTOL, COSMIN, COVPRT, COVREQ, DECFAC, DELTA0, DFAC,
     1        DINIT, DLTFDC, DLTFDJ, DTYPE, D0INIT, EPSLON, FUZZ,
     2        INCFAC, INITS, JTINIT, LMAX0, MXFCAL, MXITER, OUTLEV,
     3        PARPRT, PHMNFC, PHMXFC, PRUNIT, RDFCMN, RDFCMX,
     4        RFCTOL, RLIMIT, SOLPRT, STATPR, TUNER1, TUNER2, TUNER3,
     5        TUNER4, TUNER5, XCTOL, XFTOL, X0PRT
C
C/6
      DATA ONE/1.E+0/, THREE/3.E+0/
C/7
C     PARAMETER (ONE=1.D+0, THREE=3.D+0)
C/
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA COVPRT/14/, COVREQ/15/, DTYPE/16/, INITS/25/,
     1     MXFCAL/17/, MXITER/18/, OUTLEV/19/,
     2     PARPRT/20/, PRUNIT/21/, SOLPRT/22/,
     3     STATPR/23/, X0PRT/24/
C/7
C     PARAMETER (COVPRT=14, COVREQ=15, DTYPE=16, INITS=25,
C    1     MXFCAL=17, MXITER=18, OUTLEV=19,
C    2     PARPRT=20, PRUNIT=21, SOLPRT=22,
C    3     STATPR=23, X0PRT=24)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA AFCTOL/31/, COSMIN/43/, DECFAC/22/,
     1     DELTA0/44/, DFAC/41/, DINIT/38/, DLTFDC/40/,
     2     DLTFDJ/36/, D0INIT/37/, EPSLON/19/, FUZZ/45/,
     3     INCFAC/23/, JTINIT/39/, LMAX0/35/, PHMNFC/20/,
     4     PHMXFC/21/, RDFCMN/24/, RDFCMX/25/,
     5     RFCTOL/32/, RLIMIT/42/, TUNER1/26/,
     6     TUNER2/27/, TUNER3/28/, TUNER4/29/,
     7     TUNER5/30/, XCTOL/33/, XFTOL/34/
C/7
C     PARAMETER (AFCTOL=31, COSMIN=43, DECFAC=22,
C    1     DELTA0=44, DFAC=41, DINIT=38, DLTFDC=40,
C    2     DLTFDJ=36, D0INIT=37, EPSLON=19, FUZZ=45,
C    3     INCFAC=23, JTINIT=39, LMAX0=35, PHMNFC=20,
C    4     PHMXFC=21, RDFCMN=24, RDFCMX=25,
C    5     RFCTOL=32, RLIMIT=42, TUNER1=26,
C    6     TUNER2=27, TUNER3=28, TUNER4=29,
C    7     TUNER5=30, XCTOL=33, XFTOL=34)
C/
C
C-----------------------------------------------------------------------
C
      IV(1) = 12
      IV(COVPRT) = 1
      IV(COVREQ) = 1
      IV(DTYPE) = 1
      IV(INITS) = 0
      IV(MXFCAL) = 200
      IV(MXITER) = 150
      IV(OUTLEV) = 1
      IV(PARPRT) = 1
      IV(PRUNIT) = IMDCON(1)
      IV(SOLPRT) = 1
      IV(STATPR) = 1
      IV(X0PRT) = 1
C
      MACHEP = RMDCON(3)
      V(AFCTOL) = 1.E-20
      IF (MACHEP .GT. 1.E-10) V(AFCTOL) = MACHEP**2
      V(COSMIN) = AMAX1(1.E-6, 1.E+2 * MACHEP)
      V(DECFAC) = 0.5E+0
      SQTEPS = RMDCON(4)
      V(DELTA0) = SQTEPS
      V(DFAC) = 0.6E+0
      V(DINIT) = 0.E+0
      MEPCRT = MACHEP ** (ONE/THREE)
      V(DLTFDC) = MEPCRT
      V(DLTFDJ) = SQTEPS
      V(D0INIT) = 1.E+0
      V(EPSLON) = 0.1E+0
      V(FUZZ) = 1.5E+0
      V(INCFAC) = 2.E+0
      V(JTINIT) = 1.E-6
      V(LMAX0) = 100.E+0
      V(PHMNFC) = -0.1E+0
      V(PHMXFC) = 0.1E+0
      V(RDFCMN) = 0.1E+0
      V(RDFCMX) = 4.E+0
      V(RFCTOL) = AMAX1(1.E-10, MEPCRT**2)
      V(RLIMIT) = RMDCON(5)
      V(TUNER1) = 0.1E+0
      V(TUNER2) = 1.E-4
      V(TUNER3) = 0.75E+0
      V(TUNER4) = 0.5E+0
      V(TUNER5) = 0.75E+0
      V(XCTOL) = SQTEPS
      V(XFTOL) = 1.E+2 * MACHEP
C
 999  RETURN
C  ***  LAST CARD OF DFAULT FOLLOWS  ***
      END
      REAL FUNCTION DOTPRD(P, X, Y)                                     DOT00010
C
C  ***  RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y.  ***
C
      INTEGER P
      REAL X(P), Y(P)
C
      INTEGER I
      REAL ONE, SQTETA, T, ZERO
C/+
      REAL AMAX1, ABS
C/
      EXTERNAL RMDCON
      REAL RMDCON
C
C  ***  RMDCON(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH
C  ***  IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT
C  ***  CAN BE SQUARED WITHOUT UNDERFLOWING.
C
C/6
      DATA ONE/1.E+0/, SQTETA/0.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C     DATA SQTETA/0.D+0/
C/
C
      DOTPRD = ZERO
      IF (P .LE. 0) GO TO 999
      IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2)
      DO 20 I = 1, P
         T = AMAX1(ABS(X(I)), ABS(Y(I)))
         IF (T .GT. ONE) GO TO 10
         IF (T .LT. SQTETA) GO TO 20
         T = (X(I)/SQTETA)*Y(I)
         IF (ABS(T) .LT. SQTETA) GO TO 20
 10      DOTPRD = DOTPRD + X(I)*Y(I)
 20   CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF DOTPRD FOLLOWS  ***
      END
      SUBROUTINE DUPDAT(D, IV, J, N, NN, P, V)                          DUP00010
C
C  ***  UPDATE SCALE VECTOR D FOR NL2ITR (NL2SOL VERSION 2.2)  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IV(1), N, NN, P
      REAL D(P), J(NN,P), V(1)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER D0, I, JTOLI, S1
      REAL SII, T, VDFAC
C
C     ***  CONSTANTS  ***
      REAL ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      REAL AMAX1, SQRT
C/
C  ***  EXTERNAL FUNCTION  ***
C
      EXTERNAL V2NORM
      REAL V2NORM
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER DFAC, DTYPE, JTOL0, NITER, S
C/6
      DATA DFAC/41/, DTYPE/16/, JTOL0/86/, NITER/31/, S/53/
C/7
C     PARAMETER (DFAC=41, DTYPE=16, JTOL0=86, NITER=31, S=53)
C/
C
C/6
      DATA ZERO/0.E+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
C-----------------------------------------------------------------------
C
      I = IV(DTYPE)
      IF (I .EQ. 1) GO TO 20
         IF (IV(NITER) .GT. 0) GO TO 999
C
 20   VDFAC = V(DFAC)
      D0 = JTOL0 + P
      S1 = IV(S) - 1
      DO 30 I = 1, P
         S1 = S1 + I
         SII = V(S1)
         T = V2NORM(N, J(1,I))
         IF (SII .GT. ZERO) T = SQRT(T*T + SII)
         JTOLI = JTOL0 + I
         D0 = D0 + 1
         IF (T .LT. V(JTOLI)) T = AMAX1(V(D0), V(JTOLI))
         D(I) = AMAX1(VDFAC*D(I), T)
 30      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF DUPDAT FOLLOWS  ***
      END
      SUBROUTINE GQTSTP(D, DIG, DIHDI, KA, L, P, STEP, V, W)            GQT00010
C
C  *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER KA, P
      REAL D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P),
     1                 W(1)
C     DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C        GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
C     HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
C     THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
C     APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE.  IN
C     OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
C     PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP  SUCH THAT THE
C     2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE
C     G  IS THE GRADIENT,  H  IS THE HESSIAN, AND  D  IS A DIAGONAL
C     SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
C     (GQTSTP ASSUMES  DIG = D**-1 * G  AND  DIHDI = D**-1 * H * D**-1.)
C     IF G = 0, HOWEVER, STEP = 0 IS RETURNED (EVEN AT A SADDLE POINT).
C
C  ***  PARAMETER DESCRIPTION  ***
C
C     D (IN)  = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
C              MATRIX  D  MENTIONED ABOVE UNDER PURPOSE.
C   DIG (IN)  = THE SCALED GRADIENT VECTOR, D**-1 * G.  IF G = 0, THEN
C              STEP = 0  AND  V(STPPAR) = 0  ARE RETURNED.
C DIHDI (IN)  = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
C              I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
C              IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
C    KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
C              MINE STEP.  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
C              ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
C              -- KA IS INITIALIZED TO 0 IN THIS CASE.  OUTPUT WITH
C              KA = 0  (OR V(STPPAR) = 0)  MEANS  STEP = -(H**-1)*G.
C     L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
C     P (IN)  = NUMBER OF PARAMETERS -- THE HESSIAN IS A  P X P  MATRIX.
C  STEP (I/O) = THE STEP COMPUTED.
C     V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C     W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
C
C  ***  ENTRIES IN V  ***
C
C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP.
C V(DST0)   (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
C             OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
C V(EPSLON) (IN)  = MAX. REL. ERROR ALLOWED FOR PSI(STEP).  FOR THE
C             STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
C             BY LESS THAN -V(EPSLON)*PSI(STEP).  SUGGESTED VALUE = 0.1.
C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP)  (FOR POS. DEF.
C             H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE).
C V(PHMNFC) (IN)  = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
C             BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
C V(PHMXFC) (IN)  (SEE V(PHMNFC).)
C             SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5.
C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
C V(RADIUS) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(RAD0)   (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
C             DESCRIBED BELOW UNDER ALGORITHM NOTES.  IF H + ALPHA*D**2
C             (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
C             THEN V(STPPAR) = -ALPHA.
C
C  ***  USAGE NOTES  ***
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS).  (THIS EXPLAINS
C     WHY STEP AND W ARE LISTED AS I/O).  ON AN INTIIAL CALL (ONE WITH
C     KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
C     NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND
C     V(RAD0) OF V MUST BE INITIALIZED.  TO COMPUTE STEP FROM A SADDLE
C     POINT (WHERE THE TRUE GRADIENT VANISHES AND H HAS A NEGATIVE
C     EIGENVALUE), A NONZERO G WITH SMALL COMPONENTS SHOULD BE PASSED.
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
C     SQUARES) PACKAGE (REF. 1), BUT IT COULD BE USED IN SOLVING ANY
C     UNCONSTRAINED MINIMIZATION PROBLEM.
C
C  ***  ALGORITHM NOTES  ***
C
C        THE DESIRED G-Q-T STEP (REF. 2, 3, 4) SATISFIES
C     (H + ALPHA*D**2)*STEP = -G  FOR SOME NONNEGATIVE ALPHA SUCH THAT
C     H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE.  ALPHA AND STEP ARE
C     COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
C     ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
C     ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
C     SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 6.  CASES IN WHICH
C     H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
C     THE TECHNIQUE DISCUSSED IN REF. 2.  IN THESE CASES, A STEP OF
C     (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
C     ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP).
C
C  ***  FUNCTIONS AND SUBROUTINES CALLED  ***
C
C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS.
C LITVMU - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C LSQRT  - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
C LSVMIN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
C RMDCON - RETURNS MACHINE-DEPENDENT CONSTANTS.
C V2NORM - RETURNS 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C 2.  GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
C             SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
C             186-197.
C 3.  GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
C             MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
C             PP. 541-551.
C 4.  HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
C             SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
C             DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
C 5.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C 6.  VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
C             PP. 719-729.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      LOGICAL RESTRT
      INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC,
     1        J, K, KALIM, K1, LK0, PHIPIN, Q, Q0, UK0, X, X0
      REAL ALPHAK, AKI, AKK, DELTA, DST, EPSO6, LK,
     1                 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
     2                 ROOT, SI, SK, SW, T, TWOPSI, T1, UK, WI
C
C     ***  CONSTANTS  ***
      REAL DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, ONE,
     1                 P001, SIX, THREE, TWO, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      REAL ABS, AMAX1, AMIN1, SQRT
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DOTPRD, LITVMU, LIVMUL, LSQRT, LSVMIN, RMDCON, V2NORM
      REAL DOTPRD, LSVMIN, RMDCON, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
      INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC,
     1        PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0
C/6
      DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/,
     1     GTSTEP/4/, NREDUC/6/, PHMNFC/20/,
     2     PHMXFC/21/, PREDUC/7/, RADIUS/8/,
     3     RAD0/9/, STPPAR/5/
C/7
C     PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19,
C    1     GTSTEP=4, NREDUC=6, PHMNFC=20,
C    2     PHMXFC=21, PREDUC=7, RADIUS=8,
C    3     RAD0=9, STPPAR=5)
C/
C
C/6
      DATA EPSFAC/50.0E+0/, FOUR/4.0E+0/, HALF/0.5E+0/,
     1     KAPPA/2.0E+0/, NEGONE/-1.0E+0/, ONE/1.0E+0/, P001/1.0E-3/,
     2     SIX/6.0E+0/, THREE/3.0E+0/, TWO/2.0E+0/, ZERO/0.0E+0/
C/7
C     PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0,
C    1     KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3,
C    2     SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0)
C     SAVE DGXFAC
C/
      DATA DGXFAC/0.E+0/
C
C  ***  BODY  ***
C
C     ***  STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX).
      DGGDMX = P + 1
C     ***  STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST
C     ***  AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX)
C     ***  AND W(EMIN) RESPECTIVELY.
      EMAX = DGGDMX + 1
      EMIN = EMAX + 1
C     ***  FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST,
C     ***  AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF.
C     ***  H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN)
C     ***  RESPECTIVELY.
      LK0 = EMIN + 1
      PHIPIN = LK0 + 1
      UK0 = PHIPIN + 1
      DSTSAV = UK0 + 1
C     ***  STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P).
      DIAG0 = DSTSAV
      DIAG = DIAG0 + 1
C     ***  STORE -D*STEP IN W(Q),...,W(Q0+P).
      Q0 = DIAG0 + P
      Q = Q0 + 1
      RAD = V(RADIUS)
C     ***  PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF
C     ***  D*STEP.
      PHIMAX = V(PHMXFC) * RAD
      PHIMIN = V(PHMNFC) * RAD
C     ***  EPSO6 AND PSIFAC ARE USED IN CHECKING FOR THE SPECIAL CASE
C     ***  OF (NEARLY) SINGULAR H + ALPHA*D**2 (SEE REF. 2).
      PSIFAC = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) *
     1                       (KAPPA + ONE)  +  KAPPA  +  TWO) * RAD**2)
C     ***  OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY.  IF
C     ***  WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
      OLDPHI = ZERO
      EPSO6 = V(EPSLON)/SIX
      IRC = 0
      RESTRT = .FALSE.
      KALIM = KA + 50
C
C  ***  START OR RESTART, DEPENDING ON KA  ***
C
      IF (KA .GE. 0) GO TO 310
C
C  ***  FRESH START  ***
C
      K = 0
      UK = NEGONE
      KA = 0
      KALIM = 50
C
C     ***  STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P)  ***
C
      J = 0
      DO 20 I = 1, P
         J = J + I
         K1 = DIAG0 + I
         W(K1) = DIHDI(J)
 20      CONTINUE
C
C     ***  DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI  ***
C
      T1 = ZERO
      J = P * (P + 1) / 2
      DO 30 I = 1, J
         T = ABS(DIHDI(I))
         IF (T1 .LT. T) T1 = T
 30      CONTINUE
      W(DGGDMX) = T1
C
C  ***  TRY ALPHA = 0  ***
C
 40   CALL LSQRT(1, P, L, DIHDI, IRC)
      IF (IRC .EQ. 0) GO TO 60
C        ***  INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS
C        ***  ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA.
         J = IRC*(IRC+1)/2
         T = L(J)
         L(J) = ONE
         DO 50 I = 1, IRC
 50           W(I) = ZERO
         W(IRC) = ONE
         CALL LITVMU(IRC, W, L, W)
         T1 = V2NORM(IRC, W)
         LK = -T / T1 / T1
         V(DST0) = -LK
         IF (RESTRT) GO TO 210
         V(NREDUC) = ZERO
         GO TO 70
C
C     ***  POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP.  ***
 60   LK = ZERO
      CALL LIVMUL(P, W(Q), L, DIG)
      V(NREDUC) = HALF * DOTPRD(P, W(Q), W(Q))
      CALL LITVMU(P, W(Q), L, W(Q))
      DST = V2NORM(P, W(Q))
      V(DST0) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GO TO 280
      IF (RESTRT) GO TO 210
C
C  ***  PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND
C  ***  SMALLEST) EIGENVALUES.  ***
C
 70   V(DGNORM) = V2NORM(P, DIG)
      IF (V(DGNORM) .EQ. ZERO) GO TO 450
      K = 0
      DO 100 I = 1, P
         WI = ZERO
         IF (I .EQ. 1) GO TO 90
         IM1 = I - 1
         DO 80 J = 1, IM1
              K = K + 1
              T = ABS(DIHDI(K))
              WI = WI + T
              W(J) = W(J) + T
 80           CONTINUE
 90      W(I) = WI
         K = K + 1
 100     CONTINUE
C
C  ***  (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1)  ***
C
      K = 1
      T1 = W(DIAG) - W(1)
      IF (P .LE. 1) GO TO 120
      DO 110 I = 2, P
         J = DIAG0 + I
         T = W(J) - W(I)
         IF (T .GE. T1) GO TO 110
              T1 = T
              K = I
 110     CONTINUE
C
 120  SK = W(K)
      J = DIAG0 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = ZERO
      DO 150 I = 1, P
         IF (I .EQ. K) GO TO 130
         AKI = ABS(DIHDI(K1))
         SI = W(I)
         J = DIAG0 + I
         T1 = HALF * (AKK - W(J) + SI - AKI)
         T1 = T1 + SQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GO TO 140
 130     INC = I
 140     K1 = K1 + INC
 150     CONTINUE
C
      W(EMIN) = AKK - T
      UK = V(DGNORM)/RAD - W(EMIN)
C
C  ***  COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE  ***
C
      K = 1
      T1 = W(DIAG) + W(1)
      IF (P .LE. 1) GO TO 170
      DO 160 I = 2, P
         J = DIAG0 + I
         T = W(J) + W(I)
         IF (T .LE. T1) GO TO 160
              T1 = T
              K = I
 160     CONTINUE
C
 170  SK = W(K)
      J = DIAG0 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = ZERO
      DO 200 I = 1, P
         IF (I .EQ. K) GO TO 180
         AKI = ABS(DIHDI(K1))
         SI = W(I)
         J = DIAG0 + I
         T1 = HALF * (W(J) + SI - AKI - AKK)
         T1 = T1 + SQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GO TO 190
 180     INC = I
 190     K1 = K1 + INC
 200     CONTINUE
C
      W(EMAX) = AKK + T
      LK = AMAX1(LK, V(DGNORM)/RAD - W(EMAX))
C
C     ***  ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE).  WE
C     ***  USE MORE*S SCHEME FOR INITIALIZING IT.
      ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD
C
      IF (IRC .NE. 0) GO TO 210
C
C  ***  COMPUTE L0 FOR POSITIVE DEFINITE H  ***
C
      CALL LIVMUL(P, W, L, W(Q))
      T = V2NORM(P, W)
      W(PHIPIN) = DST / T / T
      LK = AMAX1(LK, PHI*W(PHIPIN))
C
C  ***  SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1)  ***
C
 210  KA = KA + 1
      IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     1                      ALPHAK = UK * AMAX1(P001, SQRT(LK/UK))
      K = 0
      DO 220 I = 1, P
         K = K + I
         J = DIAG0 + I
         DIHDI(K) = W(J) + ALPHAK
 220     CONTINUE
C
C  ***  TRY COMPUTING CHOLESKY DECOMPOSITION  ***
C
      CALL LSQRT(1, P, L, DIHDI, IRC)
      IF (IRC .EQ. 0) GO TO 250
C
C  ***  (D**-1)*H*(D**-1) + ALPHAK*I  IS INDEFINITE -- OVERESTIMATE
C  ***  SMALLEST EIGENVALUE FOR USE IN UPDATING LK  ***
C
      J = (IRC*(IRC+1))/2
      T = L(J)
      L(J) = ONE
      DO 230 I = 1, IRC
 230     W(I) = ZERO
      W(IRC) = ONE
      CALL LITVMU(IRC, W, L, W)
      T1 = V2NORM(IRC, W)
      LK = ALPHAK - T/T1/T1
      V(DST0) = -LK
      GO TO 210
C
C  ***  ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE.
C  ***  COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE.  ***
C
 250  CALL LIVMUL(P, W(Q), L, DIG)
      CALL LITVMU(P, W(Q), L, W(Q))
      DST = V2NORM(P, W(Q))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 290
      IF (PHI .EQ. OLDPHI) GO TO 290
      OLDPHI = PHI
      IF (PHI .GT. ZERO) GO TO 260
C        ***  CHECK FOR THE SPECIAL CASE OF  H + ALPHA*D**2  (NEARLY)
C        ***  SINGULAR.  DELTA IS .GE. THE SMALLEST EIGENVALUE OF
C        ***  (D**-1)*H*(D**-1) + ALPHAK*I.
         IF (V(DST0) .GT. ZERO) GO TO 260
         DELTA = ALPHAK + V(DST0)
         TWOPSI = ALPHAK*DST*DST + DOTPRD(P, DIG, W(Q))
         IF (DELTA .LT. PSIFAC*TWOPSI) GO TO 270
C
C  ***  UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK  ***
C
 260  IF (KA .GE. KALIM) GO TO 290
      CALL LIVMUL(P, W, L, W(Q))
      T1 = V2NORM(P, W)
C     ***  THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS  ***
      IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK)
      ALPHAK = ALPHAK  +  (PHI/T1) * (DST/T1) * (DST/RAD)
      LK = AMAX1(LK, ALPHAK)
      GO TO 210
C
C  ***  DECIDE HOW TO HANDLE (NEARLY) SINGULAR H + ALPHA*D**2  ***
C
C     ***  IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC.
 270  IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * RMDCON(3)
C
C     ***  NOW DECIDE.  ***
      IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 350
C        ***  DELTA IS SO SMALL WE CANNOT HANDLE THE SPECIAL CASE IN
C        ***  THE AVAILABLE ARITHMETIC.  ACCEPT STEP AS IT IS.
         GO TO 290
C
C  ***  ACCEPTABLE STEP ON FIRST TRY  ***
C
 280  ALPHAK = ZERO
C
C  ***  SUCCESSFUL STEP IN GENERAL.  COMPUTE STEP = -(D**-1)*Q  ***
C
 290  DO 300 I = 1, P
         J = Q0 + I
         STEP(I) = -W(J)/D(I)
 300     CONTINUE
      V(GTSTEP) = -DOTPRD(P, DIG, W(Q))
      V(PREDUC) = HALF * (ABS(ALPHAK)*DST*DST - V(GTSTEP))
      GO TO 430
C
C
C  ***  RESTART WITH NEW RADIUS  ***
C
 310  IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 330
C
C     ***  PREPARE TO RETURN NEWTON STEP  ***
C
         RESTRT = .TRUE.
         KA = KA + 1
         K = 0
         DO 320 I = 1, P
              K = K + I
              J = DIAG0 + I
              DIHDI(K) = W(J)
 320          CONTINUE
         UK = NEGONE
         GO TO 40
C
 330  IF (KA .EQ. 0) GO TO 60
C
      DST = W(DSTSAV)
      ALPHAK = ABS(V(STPPAR))
      PHI = DST - RAD
      T = V(DGNORM)/RAD
      IF (RAD .GT. V(RAD0)) GO TO 340
C
C        ***  SMALLER RADIUS  ***
         UK = T - W(EMIN)
         LK = ZERO
         IF (ALPHAK .GT. ZERO) LK = W(LK0)
         LK = AMAX1(LK, T - W(EMAX))
         IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
         GO TO 260
C
C     ***  BIGGER RADIUS  ***
 340  UK = T - W(EMIN)
      IF (ALPHAK .GT. ZERO) UK = AMIN1(UK, W(UK0))
      LK = AMAX1(ZERO, -V(DST0), T - W(EMAX))
      IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
      GO TO 260
C
C  ***  HANDLE (NEARLY) SINGULAR H + ALPHA*D**2  ***
C
C     ***  NEGATE ALPHAK TO INDICATE SPECIAL CASE  ***
 350  ALPHAK = -ALPHAK
C     ***  ALLOCATE STORAGE FOR SCRATCH VECTOR X  ***
      X0 = Q0 + P
      X = X0 + 1
C
C  ***  USE INVERSE POWER METHOD WITH START FROM LSVMIN TO OBTAIN
C  ***  APPROXIMATE EIGENVECTOR CORRESPONDING TO SMALLEST EIGENVALUE
C  ***  OF (D**-1)*H*(D**-1).
C
      DELTA = KAPPA*DELTA
      T = LSVMIN(P, L, W(X), W)
C
      K = 0
C     ***  NORMALIZE W  ***
 360  DO 370 I = 1, P
 370     W(I) = T*W(I)
C     ***  COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W.
      CALL LITVMU(P, W, L, W)
      T1 = ONE/V2NORM(P, W)
      T = T1*T
      IF (T .LE. DELTA) GO TO 390
      IF (K .GT. 30) GO TO 290
      K = K + 1
C     ***  START NEXT INV. POWER ITER. BY STORING NORMALIZED W IN X.
      DO 380 I = 1, P
         J = X0 + I
         W(J) = T1*W(I)
 380     CONTINUE
C     ***  COMPUTE W = (L**-1)*X.
      CALL LIVMUL(P, W, L, W(X))
      T = ONE/V2NORM(P, W)
      GO TO 360
C
 390  DO 400 I = 1, P
 400     W(I) = T1*W(I)
C
C  ***  NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND
C  ***  T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
C
      SW = DOTPRD(P, W(Q), W)
      T1 = (RAD + DST) * (RAD - DST)
      ROOT = SQRT(SW*SW + T1)
      IF (SW .LT. ZERO) ROOT = -ROOT
      SI = T1 / (SW + ROOT)
C     ***  ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A
C     ***  FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3.
      V(PREDUC) = HALF*TWOPSI
      T1 = ZERO
      T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DOTPRD(P,W(X),W)))
      IF (T .LT. EPSO6*TWOPSI) GO TO 410
         V(PREDUC) = V(PREDUC) + T
         DST = RAD
         T1 = -SI
 410  DO 420 I = 1, P
         J = Q0 + I
         W(J) = T1*W(I) - W(J)
         STEP(I) = W(J) / D(I)
 420     CONTINUE
      V(GTSTEP) = DOTPRD(P, DIG, W(Q))
C
C  ***  SAVE VALUES FOR USE IN A POSSIBLE RESTART  ***
C
 430  V(DSTNRM) = DST
      V(STPPAR) = ALPHAK
      W(LK0) = LK
      W(UK0) = UK
      V(RAD0) = RAD
      W(DSTSAV) = DST
C
C     ***  RESTORE DIAGONAL OF DIHDI  ***
C
      J = 0
      DO 440 I = 1, P
         J = J + I
         K = DIAG0 + I
         DIHDI(J) = W(K)
 440     CONTINUE
      GO TO 999
C
C  ***  SPECIAL CASE -- G = 0  ***
C
 450  V(STPPAR) = ZERO
      V(PREDUC) = ZERO
      V(DSTNRM) = ZERO
      V(GTSTEP) = ZERO
      DO 460 I = 1, P
 460     STEP(I) = ZERO
C
 999  RETURN
C
C  ***  LAST CARD OF GQTSTP FOLLOWS  ***
      END
      SUBROUTINE ITSMRY(D, IV, P, V, X)                                 ITS00010
C
C  ***  PRINT NL2SOL (VERSION 2.2) ITERATION SUMMARY  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IV(1), P
      REAL D(P), V(1), X(P)
C     DIMENSION IV(*), V(*)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER COV1, G1, I, II, IV1, I1, J, M, NF, NG, OL, PU
C/6
      REAL MODEL1(6), MODEL2(6)
C/7
C     CHARACTER*4 MODEL1(6), MODEL2(6)
C/
      REAL NRELDF, OLDF, PRELDF, RELDF, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
C/
C  ***  NO EXTERNAL FUNCTIONS OR SUBROUTINES  ***
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER COVMAT, COVPRT, COVREQ, DSTNRM, F, FDIF, F0, G,
     1        NEEDHD, NFCALL, NFCOV, NGCOV, NGCALL, NITER, NREDUC,
     2        OUTLEV, PREDUC, PRNTIT, PRUNIT, RELDX, SIZE, SOLPRT,
     3        STATPR, STPPAR, SUSED, X0PRT
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA COVMAT/26/, COVPRT/14/, G/28/, COVREQ/15/,
     1     NEEDHD/39/, NFCALL/6/, NFCOV/40/, NGCOV/41/,
     2     NGCALL/30/, NITER/31/, OUTLEV/19/, PRNTIT/48/,
     3     PRUNIT/21/, SOLPRT/22/, STATPR/23/, SUSED/57/,
     4     X0PRT/24/
C/7
C     PARAMETER (COVMAT=26, COVPRT=14, G=28, COVREQ=15,
C    1     NEEDHD=39, NFCALL=6, NFCOV=40, NGCOV=41,
C    2     NGCALL=30, NITER=31, OUTLEV=19, PRNTIT=48,
C    3     PRUNIT=21, SOLPRT=22, STATPR=23, SUSED=57,
C    4     X0PRT=24)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/,
     1     PREDUC/7/, RELDX/17/, SIZE/47/, STPPAR/5/
C/7
C     PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6,
C    1     PREDUC=7, RELDX=17, SIZE=47, STPPAR=5)
C/
C
C/6
      DATA ZERO/0.E+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C/6
      DATA MODEL1(1)/4H    /, MODEL1(2)/4H    /, MODEL1(3)/4H    /,
     1     MODEL1(4)/4H    /, MODEL1(5)/4H  G /, MODEL1(6)/4H  S /,
     2     MODEL2(1)/4H G  /, MODEL2(2)/4H S  /, MODEL2(3)/4HG-S /,
     3     MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/
C/7
C     DATA MODEL1/'    ','    ','    ','    ','  G ','  S '/,
C    1     MODEL2/' G  ',' S  ','G-S ','S-G ','-S-G','-G-S'/
C/
C
C-----------------------------------------------------------------------
C
      PU = IV(PRUNIT)
      IF (PU .EQ. 0) GO TO 999
      IV1 = IV(1)
      OL = IV(OUTLEV)
      IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 140
      IF (OL .EQ. 0) GO TO 20
      IF (IV1 .GE. 12) GO TO 20
      IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 20
      IF (IV1 .GT. 2) GO TO 10
         IV(PRNTIT) = IV(PRNTIT) + 1
         IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999
 10   NF = IV(NFCALL) - IABS(IV(NFCOV))
      IV(PRNTIT) = 0
      RELDF = ZERO
      PRELDF = ZERO
      OLDF = V(F0)
      IF (OLDF .LE. ZERO) GO TO 12
         RELDF = V(FDIF) / OLDF
         PRELDF = V(PREDUC) / OLDF
 12   IF (OL .GT. 0) GO TO 15
C
C        ***  PRINT SHORT SUMMARY LINE  ***
C
         IF (IV(NEEDHD) .EQ. 1) WRITE(PU, 1010)
 1010 FORMAT(12H0   IT    NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX)
         IV(NEEDHD) = 0
         WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX)
         GO TO 20
C
C     ***  PRINT LONG SUMMARY LINE  ***
C
 15   IF (IV(NEEDHD) .EQ. 1) WRITE(PU,1015)
 1015 FORMAT(12H0   IT    NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX,
     1       4X,15HMODEL    STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF)
      IV(NEEDHD) = 0
      M = IV(SUSED)
      NRELDF = ZERO
      IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF
      WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
     1               MODEL1(M), MODEL2(M), V(STPPAR), V(SIZE),
     2               V(DSTNRM), NRELDF
 1017 FORMAT(1X,I5,I6,4E11.3,A3,A4,4E11.3)
C
 20   GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1
C
 30   WRITE(PU,1030)
 1030 FORMAT(26H0***** X-CONVERGENCE *****)
      GO TO 180
C
 35   WRITE(PU,1035)
 1035 FORMAT(42H0***** RELATIVE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 40   WRITE(PU,1040)
 1040 FORMAT(49H0***** X- AND RELATIVE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 45   WRITE(PU,1045)
 1045 FORMAT(42H0***** ABSOLUTE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 50   WRITE(PU,1050)
 1050 FORMAT(33H0***** SINGULAR CONVERGENCE *****)
      GO TO 180
C
 60   WRITE(PU,1060)
 1060 FORMAT(30H0***** FALSE CONVERGENCE *****)
      GO TO 180
C
 70   WRITE(PU,1070)
 1070 FORMAT(38H0***** FUNCTION EVALUATION LIMIT *****)
      GO TO 180
C
 80   WRITE(PU,1080)
 1080 FORMAT(28H0***** ITERATION LIMIT *****)
      GO TO 180
C
 90   WRITE(PU,1090)
 1090 FORMAT(18H0***** STOPX *****)
      GO TO 180
C
 110  WRITE(PU,1100)
 1100 FORMAT(45H0***** INITIAL SUM OF SQUARES OVERFLOWS *****)
C
      GO TO 150
C
 120  WRITE(PU,1120)
 1120 FORMAT(37H0***** BAD PARAMETERS TO ASSESS *****)
      GO TO 999
C
 130  WRITE(PU,1130)
 1130 FORMAT(36H0***** J COULD NOT BE COMPUTED *****)
      IF (IV(NITER) .GT. 0) GO TO 190
      GO TO 150
C
 140  WRITE(PU,1140) IV1
 1140 FORMAT(14H0***** IV(1) =,I5,6H *****)
      GO TO 999
C
C  ***  INITIAL CALL ON ITSMRY  ***
C
 150  IF (IV(X0PRT) .NE. 0) WRITE(PU,1150) (I, X(I), D(I), I = 1, P)
 1150 FORMAT(23H0    I     INITIAL X(I),7X,4HD(I)//(1X,I5,E17.6,E14.3))
      IF (IV1 .GE. 13) GO TO 999
      IV(NEEDHD) = 0
      IV(PRNTIT) = 0
      IF (OL .EQ. 0) GO TO 999
      IF (OL .LT. 0) WRITE(PU,1010)
      IF (OL .GT. 0) WRITE(PU,1015)
      WRITE(PU,1160) V(F)
 1160 FORMAT(12H0    0     1,E11.3,11X,E11.3)
      GO TO 999
C
C  ***  PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION  ***
C
 180  IV(NEEDHD) = 1
      IF (IV(STATPR) .EQ. 0) GO TO 190
         OLDF = V(F0)
         PRELDF = ZERO
         NRELDF = ZERO
         IF (OLDF .LE. ZERO) GO TO 185
              PRELDF = V(PREDUC) / OLDF
              NRELDF = V(NREDUC) / OLDF
 185     NF = IV(NFCALL) - IV(NFCOV)
         NG = IV(NGCALL) - IV(NGCOV)
         WRITE(PU,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF
 1180 FORMAT(9H0FUNCTION,E17.6,8H   RELDX,E20.6/12H FUNC. EVALS,
     1   I8,9X,11HGRAD. EVALS,I8/7H PRELDF,E19.6,3X,7HNPRELDF,E18.6)
C
         IF (IV(NFCOV) .GT. 0) WRITE(PU,1185) IV(NFCOV)
 1185    FORMAT(1H0,I4,34H EXTRA FUNC. EVALS FOR COVARIANCE.)
         IF (IV(NGCOV) .GT. 0) WRITE(PU,1186) IV(NGCOV)
 1186    FORMAT(1X,I4,34H EXTRA GRAD. EVALS FOR COVARIANCE.)
C
 190  IF (IV(SOLPRT) .EQ. 0) GO TO 210
         IV(NEEDHD) = 1
         G1 = IV(G)
         WRITE(PU,1190)
 1190 FORMAT(22H0    I      FINAL X(I),8X,4HD(I),10X,4HG(I)/)
         DO 200 I = 1, P
              WRITE(PU,1200) I, X(I), D(I), V(G1)
              G1 = G1 + 1
 200          CONTINUE
 1200    FORMAT(1X,I5,E17.6,2E14.3)
C
 210  IF (IV(COVPRT) .EQ. 0) GO TO 999
      COV1 = IV(COVMAT)
      IV(NEEDHD) = 1
      IF (COV1) 220, 230, 240
 220  IF (-1 .EQ. COV1) WRITE(PU,1220)
 1220 FORMAT(43H0++++++ INDEFINITE COVARIANCE MATRIX ++++++)
      IF (-2 .EQ. COV1) WRITE(PU,1225)
 1225 FORMAT(52H0++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++)
      GO TO 999
C
 230  WRITE(PU,1230)
 1230 FORMAT(45H0++++++ COVARIANCE MATRIX NOT COMPUTED ++++++)
      GO TO 999
C
 240  I = IABS(IV(COVREQ))
      IF (I .LE. 1) WRITE(PU,1241)
 1241 FORMAT(48H0COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/)
      IF (I .EQ. 2) WRITE(PU,1242)
 1242 FORMAT(27H0COVARIANCE = SCALE * H**-1/)
      IF (I .GE. 3) WRITE(PU,1243)
 1243 FORMAT(36H0COVARIANCE = SCALE * (J**T * J)**-1/)
      II = COV1 - 1
      IF (OL .LE. 0) GO TO 260
      DO 250 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(PU,1250) I, (V(J), J = I1, II)
 250     CONTINUE
 1250 FORMAT(4H ROW,I3,2X,9E12.4/(9X,9E12.4))
      GO TO 999
C
 260  DO 270 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(PU,1270) I, (V(J), J = I1, II)
 270     CONTINUE
 1270 FORMAT(4H ROW,I3,2X,5E12.4/(9X,5E12.4))
C
 999  RETURN
C  ***  LAST CARD OF ITSMRY FOLLOWS  ***
      END
      SUBROUTINE LINVRT(N, LIN, L)                                      LIN00010
C
C  ***  COMPUTE  LIN = L**-1,  BOTH  N X N  LOWER TRIANG. STORED   ***
C  ***  COMPACTLY BY ROWS.  LIN AND L MAY SHARE THE SAME STORAGE.  ***
C
C  ***  PARAMETERS  ***
C
      INTEGER N
      REAL L(1), LIN(1)
C     DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
      REAL ONE, T, ZERO
C/6
      DATA ONE/1.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
      NP1 = N + 1
      J0 = N*(NP1)/2
      DO 30 II = 1, N
         I = NP1 - II
         LIN(J0) = ONE/L(J0)
         IF (I .LE. 1) GO TO 999
         J1 = J0
         IM1 = I - 1
         DO 20 JJ = 1, IM1
              T = ZERO
              J0 = J1
              K0 = J1 - JJ
              DO 10 K = 1, JJ
                   T = T - L(K0)*LIN(J0)
                   J0 = J0 - 1
                   K0 = K0 + K - I
 10                CONTINUE
              LIN(J0) = T/L(K0)
 20           CONTINUE
         J0 = J0 - 1
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LINVRT FOLLOWS  ***
      END
      SUBROUTINE LITVMU(N, X, L, Y)                                     LIT00010
C
C  ***  SOLVE  (L**T)*X = Y,  WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
      INTEGER N
      REAL X(N), L(1), Y(N)
      INTEGER I, II, IJ, IM1, I0, J, NP1
      REAL XI, ZERO
C/6
      DATA ZERO/0.E+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
      DO 10 I = 1, N
 10      X(I) = Y(I)
      NP1 = N + 1
      I0 = N*(N+1)/2
      DO 30 II = 1, N
         I = NP1 - II
         XI = X(I)/L(I0)
         X(I) = XI
         IF (I .LE. 1) GO TO 999
         I0 = I0 - I
         IF (XI .EQ. ZERO) GO TO 30
         IM1 = I - 1
         DO 20 J = 1, IM1
              IJ = I0 + J
              X(J) = X(J) - XI*L(IJ)
 20           CONTINUE
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LITVMU FOLLOWS  ***
      END
      SUBROUTINE LIVMUL(N, X, L, Y)                                     LIV00010
C
C  ***  SOLVE  L*X = Y, WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
      INTEGER N
      REAL X(N), L(1), Y(N)
      EXTERNAL DOTPRD
      REAL DOTPRD
      INTEGER I, J, K
      REAL T, ZERO
C/6
      DATA ZERO/0.E+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
      DO 10 K = 1, N
         IF (Y(K) .NE. ZERO) GO TO 20
         X(K) = ZERO
 10      CONTINUE
      GO TO 999
 20   J = K*(K+1)/2
      X(K) = Y(K) / L(J)
      IF (K .GE. N) GO TO 999
      K = K + 1
      DO 30 I = K, N
         T = DOTPRD(I-1, L(J+1), X)
         J = J + I
         X(I) = (Y(I) - T)/L(J)
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LIVMUL FOLLOWS  ***
      END
      SUBROUTINE LMSTEP(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W)  LMS00010
C
C  ***  COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE  **
C  ***  NL2SOL VERSION 2.2.  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IERR, KA, P
      INTEGER IPIVOT(P)
      REAL D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1)
C     DIMENSION W(P*(P+5)/2 + 4)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C        GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN
C     MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING
C     RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG-
C     MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE-
C     TECHNIQUE.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C      D (IN)  = THE SCALE VECTOR.
C      G (IN)  = THE GRADIENT VECTOR (J**T)*R.
C   IERR (I/O) = RETURN CODE FROM QRFACT OR QRFGS -- 0 MEANS R HAS
C             FULL RANK.
C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR QRFGS, WHICH COMPUTE
C             QR DECOMPOSITIONS WITH COLUMN PIVOTING.
C     KA (I/O).  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON
C             LMSTEP FOR THE CURRENT R AND QTR.  ON OUTPUT KA CON-
C             TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE
C             STEP.  KA = 0 MEANS A GAUSS-NEWTON STEP.
C      P (IN)  = NUMBER OF PARAMETERS.
C    QTR (IN)  = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR.
C      R (IN)  = THE R MATRIX, STORED COMPACTLY BY COLUMNS.
C   STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED.
C      V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C      W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4.
C
C  ***  ENTRIES IN V  ***
C
C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
C V(DSTNRM) (I/O) = 2-NORM OF D*STEP.
C V(DST0)   (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J).
C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS
C             TWONORM(R - J*STEP)**2.  (SEE ALGORITHM NOTES BELOW.)
C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
C             FOR A GAUSS-NEWTON STEP.
C V(PHMNFC) (IN)  = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
C             BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
C V(PHMXFC) (IN)  (SEE V(PHMNFC).)
C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
C             BY THE STEP RETURNED.
C V(RADIUS) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(RAD0)   (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL
C             CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS).
C
C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS.
C
C  ***  USAGE NOTES  ***
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS).  (THIS EXPLAINS
C     WHY MANY PARAMETERS ARE LISTED AS I/O).  ON AN INTIIAL CALL (ONE
C     WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P,
C     QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0).
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
C     SQUARES) PACKAGE (REF. 1).
C
C  ***  ALGORITHM NOTES  ***
C
C     THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN
C     REFS. 2 AND 4.  FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60-
C     62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER.
C        A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS)
C     IS SUFFICIENTLY LARGE.  IN THIS CASE THE STEP RETURNED IS SUCH
C     THAT  TWONORM(R)**2 - TWONORM(R - J*STEP)**2  DIFFERS FROM ITS
C     OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE,
C     WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL.  (SEE
C     REF. 2 FOR MORE DETAILS.)
C
C  ***  FUNCTIONS AND SUBROUTINES CALLED  ***
C
C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS.
C LITVMU - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C VCOPY  - COPIES ONE VECTOR TO ANOTHER.
C V2NORM - RETURNS 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C 2.  GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED
C             SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2,
C             186-197.
C 3.  LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES
C             PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J.
C 4.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN,
     1        PP1O2, RES, RES0, RMAT, RMAT0, UK0
      REAL A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2,
     1                 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
     2                 SI, SJ, SQRTAK, T, TWOPSI, UK, WL
C
C     ***  CONSTANTS  ***
      REAL DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE,
     1                 TTOL, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      REAL ABS, AMAX1, AMIN1, SQRT
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DOTPRD, LITVMU, LIVMUL, VCOPY, V2NORM
      REAL DOTPRD, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
      INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
     1        PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
C/6
      DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/,
     1     GTSTEP/4/, NREDUC/6/, PHMNFC/20/,
     2     PHMXFC/21/, PREDUC/7/, RADIUS/8/,
     3     RAD0/9/, STPPAR/5/
C/7
C     PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19,
C    1     GTSTEP=4, NREDUC=6, PHMNFC=20,
C    2     PHMXFC=21, PREDUC=7, RADIUS=8,
C    3     RAD0=9, STPPAR=5)
C/
C
C/6
      DATA DFAC/256.E+0/, EIGHT/8.E+0/, HALF/0.5E+0/, NEGONE/-1.E+0/,
     1     ONE/1.E+0/, P001/1.E-3/, THREE/3.E+0/, TTOL/2.5E+0/,
     2     ZERO/0.E+0/
C/7
C     PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0,
C    1     ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0,
C    2     ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
C     ***  FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK,
C     ***  THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J)
C     ***  AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0),
C     ***  W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY.
      LK0 = P + 1
      PHIPIN = LK0 + 1
      UK0 = PHIPIN + 1
      DSTSAV = UK0 + 1
      RMAT0 = DSTSAV
C     ***  A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS
C     ***  STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL
C     ***  VECTOR IS STORED IN W STARTING AT W(RES).  THE LOOPS BELOW
C     ***  THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER
C     ***  WORK ON THESE COPIES.
      RMAT = RMAT0 + 1
      PP1O2 = P * (P + 1) / 2
      RES0 = PP1O2 + RMAT0
      RES = RES0 + 1
      RAD = V(RADIUS)
      IF (RAD .GT. ZERO)
     1   PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2)
      PHIMAX = V(PHMXFC) * RAD
      PHIMIN = V(PHMNFC) * RAD
C     ***  DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS
C     ***  REPRESENTATION OF THE UPDATED QR DECOMPOSITION.
      DTOL = ONE/DFAC
      DFACSQ = DFAC*DFAC
C     ***  OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY.  IF
C     ***  WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
      OLDPHI = ZERO
      LK = ZERO
      UK = ZERO
      KALIM = KA + 12
C
C  ***  START OR RESTART, DEPENDING ON KA  ***
C
      IF (KA) 10, 20, 370
C
C  ***  FRESH START -- COMPUTE V(NREDUC)  ***
C
 10   KA = 0
      KALIM = 12
      K = P
      IF (IERR .NE. 0) K = IABS(IERR) - 1
      V(NREDUC) = HALF*DOTPRD(K, QTR, QTR)
C
C  ***  SET UP TO TRY INITIAL GAUSS-NEWTON STEP  ***
C
 20   V(DST0) = NEGONE
      IF (IERR .NE. 0) GO TO 90
C
C  ***  COMPUTE GAUSS-NEWTON STEP  ***
C
C     ***  NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN
C     ***  R(1), R(2), R(3), ...  IT IS THE TRANSPOSE OF A
C     ***  LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE
C     ***  TREAT IT AS SUCH WHEN USING LITVMU AND LIVMUL.
      CALL LITVMU(P, W, R, QTR)
C     ***  TEMPORARILY STORE PERMUTED -D*STEP IN STEP.
      DO 60 I = 1, P
         J1 = IPIVOT(I)
         STEP(I) = D(J1)*W(I)
 60      CONTINUE
      DST = V2NORM(P, STEP)
      V(DST0) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GO TO 410
C     ***  IF THIS IS A RESTART, GO TO 110  ***
      IF (KA .GT. 0) GO TO 110
C
C  ***  GAUSS-NEWTON STEP WAS UNACCEPTABLE.  COMPUTE L0  ***
C
      DO 70 I = 1, P
         J1 = IPIVOT(I)
         STEP(I) = D(J1)*(STEP(I)/DST)
 70      CONTINUE
      CALL LIVMUL(P, STEP, R, STEP)
      T = ONE / V2NORM(P, STEP)
      W(PHIPIN) = (T/DST)*T
      LK = PHI*W(PHIPIN)
C
C  ***  COMPUTE U0  ***
C
 90   DO 100 I = 1, P
 100     W(I) = G(I)/D(I)
      V(DGNORM) = V2NORM(P, W)
      UK = V(DGNORM)/RAD
      IF (UK .LE. ZERO) GO TO 390
C
C     ***  ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER.  WE
C     ***  USE MORE*S SCHEME FOR INITIALIZING IT.
      ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD
C
C
C  ***  TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES  ***
C
 110  KA = KA + 1
      CALL VCOPY(PP1O2, W(RMAT), R)
      CALL VCOPY(P, W(RES), QTR)
C
C  ***  SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR.  ***
C
      IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     1             ALPHAK = UK * AMAX1(P001, SQRT(LK/UK))
      SQRTAK = SQRT(ALPHAK)
      DO 120 I = 1, P
 120     W(I) = ONE
C
C  ***  ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS.  ***
C
      DO 270 I = 1, P
C        ***  GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D.
C        ***  (USE STEP TO STORE TEMPORARY ROW)  ***
         L = I*(I+1)/2 + RMAT0
         WL = W(L)
         D2 = ONE
         D1 = W(I)
         J1 = IPIVOT(I)
         ADI = SQRTAK*D(J1)
         IF (ADI .GE. ABS(WL)) GO TO 150
 130     A = ADI/WL
         B = D2*A/D1
         T = A*B + ONE
         IF (T .GT. TTOL) GO TO 150
         W(I) = D1/T
         D2 = D2/T
         W(L) = T*WL
         A = -A
         DO 140 J1 = I, P
              L = L + J1
              STEP(J1) = A*W(L)
 140          CONTINUE
         GO TO 170
C
 150     B = WL/ADI
         A = D1*B/D2
         T = A*B + ONE
         IF (T .GT. TTOL) GO TO 130
         W(I) = D2/T
         D2 = D1/T
         W(L) = T*ADI
         DO 160 J1 = I, P
              L = L + J1
              WL = W(L)
              STEP(J1) = -WL
              W(L) = A*WL
 160          CONTINUE
C
 170     IF (I .EQ. P) GO TO 280
C
C        ***  NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW  ***
C
         IP1 = I + 1
         DO 260 I1 = IP1, P
              L = I1*(I1+1)/2 + RMAT0
              WL = W(L)
              SI = STEP(I1-1)
              D1 = W(I1)
C
C             ***  RESCALE ROW I1 IF NECESSARY  ***
C
              IF (D1 .GE. DTOL) GO TO 190
                   D1 = D1*DFACSQ
                   WL = WL/DFAC
                   K = L
                   DO 180 J1 = I1, P
                        K = K + J1
                        W(K) = W(K)/DFAC
 180                    CONTINUE
C
C             ***  USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW
C
 190          IF (ABS(SI) .GT. ABS(WL)) GO TO 220
              IF (SI .EQ. ZERO) GO TO 260
 200          A = SI/WL
              B = D2*A/D1
              T = A*B + ONE
              IF (T .GT. TTOL) GO TO 220
              W(L) = T*WL
              W(I1) = D1/T
              D2 = D2/T
              DO 210 J1 = I1, P
                   L = L + J1
                   WL = W(L)
                   SJ = STEP(J1)
                   W(L) = WL + B*SJ
                   STEP(J1) = SJ - A*WL
 210               CONTINUE
              GO TO 240
C
 220          B = WL/SI
              A = D1*B/D2
              T = A*B + ONE
              IF (T .GT. TTOL) GO TO 200
              W(I1) = D2/T
              D2 = D1/T
              W(L) = T*SI
              DO 230 J1 = I1, P
                   L = L + J1
                   WL = W(L)
                   SJ = STEP(J1)
                   W(L) = A*WL + SJ
                   STEP(J1) = B*SJ - WL
 230               CONTINUE
C
C             ***  RESCALE TEMP. ROW IF NECESSARY  ***
C
 240          IF (D2 .GE. DTOL) GO TO 260
                   D2 = D2*DFACSQ
                   DO 250 K = I1, P
 250                    STEP(K) = STEP(K)/DFAC
 260          CONTINUE
 270     CONTINUE
C
C  ***  COMPUTE STEP  ***
C
 280  CALL LITVMU(P, W(RES), W(RMAT), W(RES))
C     ***  RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES)  ***
      DO 290 I = 1, P
         J1 = IPIVOT(I)
         K = RES0 + I
         T = W(K)
         STEP(J1) = -T
         W(K) = T*D(J1)
 290     CONTINUE
      DST = V2NORM(P, W(RES))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430
      IF (OLDPHI .EQ. PHI) GO TO 430
      OLDPHI = PHI
C
C  ***  CHECK FOR (AND HANDLE) SPECIAL CASE  ***
C
      IF (PHI .GT. ZERO) GO TO 310
         IF (KA .GE. KALIM) GO TO 430
              TWOPSI = ALPHAK*DST*DST - DOTPRD(P, STEP, G)
              IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310
                   V(STPPAR) = -ALPHAK
                   GO TO 440
C
C  ***  UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN  ***
C
 300  IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK)
      GO TO 320
 310  IF (PHI .LT. ZERO) UK = ALPHAK
 320  DO 330 I = 1, P
         J1 = IPIVOT(I)
         K = RES0 + I
         STEP(I) = D(J1) * (W(K)/DST)
 330     CONTINUE
      CALL LIVMUL(P, STEP, W(RMAT), STEP)
      DO 340 I = 1, P
 340     STEP(I) = STEP(I) / SQRT(W(I))
      T = ONE / V2NORM(P, STEP)
      ALPHAK = ALPHAK + T*PHI*T/RAD
      LK = AMAX1(LK, ALPHAK)
      GO TO 110
C
C  ***  RESTART  ***
C
 370  LK = W(LK0)
      UK = W(UK0)
      IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20
      ALPHAK = ABS(V(STPPAR))
      DST = W(DSTSAV)
      PHI = DST - RAD
      T = V(DGNORM)/RAD
      IF (RAD .GT. V(RAD0)) GO TO 380
C
C        ***  SMALLER RADIUS  ***
         UK = T
         IF (ALPHAK .LE. ZERO) LK = ZERO
         IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
         GO TO 300
C
C     ***  BIGGER RADIUS  ***
 380  IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T
      LK = ZERO
      IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
      GO TO 300
C
C  ***  SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR)  ***
C
 390  V(STPPAR) = ZERO
      DST = ZERO
      LK = ZERO
      UK = ZERO
      V(GTSTEP) = ZERO
      V(PREDUC) = ZERO
      DO 400 I = 1, P
 400     STEP(I) = ZERO
      GO TO 450
C
C  ***  ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W  ***
C
 410  ALPHAK = ZERO
      DO 420 I = 1, P
         J1 = IPIVOT(I)
         STEP(J1) = -W(I)
 420     CONTINUE
C
C  ***  SAVE VALUES FOR USE IN A POSSIBLE RESTART  ***
C
 430  V(STPPAR) = ALPHAK
 440  V(GTSTEP) = DOTPRD(P, STEP, G)
      V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP))
 450  V(DSTNRM) = DST
      W(DSTSAV) = DST
      W(LK0) = LK
      W(UK0) = UK
      V(RAD0) = RAD
C
 999  RETURN
C
C  ***  LAST CARD OF LMSTEP FOLLOWS  ***
      END
      SUBROUTINE LSQRT(N1, N, L, A, IRC)                                LSQ00010
C
C  ***  COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR  L  OF
C  ***  A = L*(L**T),  WHERE  L  AND THE LOWER TRIANGLE OF  A  ARE BOTH
C  ***  STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
C  ***  IRC = 0 MEANS ALL WENT WELL.  IRC = J MEANS THE LEADING
C  ***  PRINCIPAL  J X J  SUBMATRIX OF  A  IS NOT POSITIVE DEFINITE --
C  ***  AND  L(J*(J+1)/2)  CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
C
C  ***  PARAMETERS  ***
C
      INTEGER N1, N, IRC
      REAL L(1), A(1)
C     DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
      REAL T, TD, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      REAL SQRT
C/
C/6
      DATA ZERO/0.E+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
      I0 = N1 * (N1 - 1) / 2
      DO 50 I = N1, N
         TD = ZERO
         IF (I .EQ. 1) GO TO 40
         J0 = 0
         IM1 = I - 1
         DO 30 J = 1, IM1
              T = ZERO
              IF (J .EQ. 1) GO TO 20
              JM1 = J - 1
              DO 10 K = 1, JM1
                   IK = I0 + K
                   JK = J0 + K
                   T = T + L(IK)*L(JK)
 10                CONTINUE
 20           IJ = I0 + J
              J0 = J0 + J
              T = (A(IJ) - T) / L(J0)
              L(IJ) = T
              TD = TD + T*T
 30           CONTINUE
 40      I0 = I0 + I
         T = A(I0) - TD
         IF (T .LE. ZERO) GO TO 60
         L(I0) = SQRT(T)
 50      CONTINUE
C
      IRC = 0
      GO TO 999
C
 60   L(I0) = T
      IRC = I
C
 999  RETURN
C
C  ***  LAST CARD OF LSQRT  ***
      END
      REAL FUNCTION LSVMIN(P, L, X, Y)                                  LSV00010
C
C  ***  ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      REAL L(1), X(P), Y(P)
C     DIMENSION L(P*(P+1)/2)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C     THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST
C     SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C  P (IN)  = THE ORDER OF L.  L IS A  P X P  LOWER TRIANGULAR MATRIX.
C  L (IN)  = ARRAY HOLDING THE ELEMENTS OF  L  IN ROW ORDER, I.E.
C             L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
C  X (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
C             APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
C             SMALLEST SINGULAR VALUE.  THIS APPROXIMATION MAY BE VERY
C             CRUDE.  IF LSVMIN RETURNS ZERO, THEN SOME COMPONENTS OF X
C             ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
C  Y (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
C             UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
C             ING TO THE SMALLEST SINGULAR VALUE.  THIS APPROXIMATION
C             MAY BE CRUDE.  IF LSVMIN RETURNS ZERO, THEN Y RETAINS ITS
C             INPUT VALUE.  THE CALLER MAY PASS THE SAME VECTOR FOR X
C             AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
C             WRITES X (FOR NONZERO LSVMIN RETURNS).
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THERE ARE NO USAGE RESTRICTIONS.
C
C  ***  ALGORITHM NOTES  ***
C
C     THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
C     LSVMIN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
C     (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
C     LARGEST.  THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
C     IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
C     (2) AND (3).
C
C  ***  SUBROUTINES AND FUNCTIONS CALLED  ***
C
C        V2NORM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C     (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
C         AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
C         TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
C
C     (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
C         RANDOM-NUMBER GENERATORS --  AN EMPIRICAL VIEW,
C         MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
C
C     (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
C         (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
C
C     (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
C         GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
C         PP. 586-593.
C
C  ***  HISTORY  ***
C
C     DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PPLUS1
      REAL B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS
C
C  ***  CONSTANTS  ***
C
      REAL HALF, ONE, R9973, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER MOD
      REAL ABS, FLOAT
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL V2NORM
      REAL V2NORM
C
C/6
      DATA HALF/0.5E+0/, ONE/1.E+0/, R9973/9973.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
C     SAVE IX
C/
      DATA IX/2/
C
C  ***  BODY  ***
C
C  ***  FIRST CHECK WHETHER TO RETURN LSVMIN = 0 AND INITIALIZE X  ***
C
      II = 0
      DO 10 I = 1, P
         X(I) = ZERO
         II = II + I
         IF (L(II) .EQ. ZERO) GO TO 300
 10      CONTINUE
      IF (MOD(IX, 9973) .EQ. 0) IX = 2
      PPLUS1 = P + 1
C
C  ***  SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
C  ***  CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
C
C     DO J = P TO 1 BY -1...
      DO 100 JJJ = 1, P
         J = PPLUS1 - JJJ
C       ***  DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
C       ***  THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
         IX = MOD(3432*IX, 9973)
         B = HALF*(ONE + FLOAT(IX)/R9973)
         XPLUS = (B - X(J))
         XMINUS = (-B - X(J))
         SPLUS = ABS(XPLUS)
         SMINUS = ABS(XMINUS)
         JM1 = J - 1
         J0 = J*JM1/2
         JJ = J0 + J
         XPLUS = XPLUS/L(JJ)
         XMINUS = XMINUS/L(JJ)
         IF (JM1 .EQ. 0) GO TO 30
         DO 20 I = 1, JM1
              JI = J0 + I
              SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS)
              SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS)
 20           CONTINUE
 30      IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
         X(J) = XPLUS
C       ***  UPDATE PARTIAL SUMS  ***
         IF (JM1 .EQ. 0) GO TO 100
         DO 40 I = 1, JM1
              JI = J0 + I
              X(I) = X(I) + L(JI)*XPLUS
 40           CONTINUE
 100     CONTINUE
C
C  ***  NORMALIZE X  ***
C
      T = ONE/V2NORM(P, X)
      DO 110 I = 1, P
 110     X(I) = T*X(I)
C
C  ***  SOLVE L*Y = X AND RETURN SVMIN = 1/TWONORM(Y)  ***
C
      DO 200 J = 1, P
         PSJ = ZERO
         JM1 = J - 1
         J0 = J*JM1/2
         IF (JM1 .EQ. 0) GO TO 130
         DO 120 I = 1, JM1
              JI = J0 + I
              PSJ = PSJ + L(JI)*Y(I)
 120          CONTINUE
 130     JJ = J0 + J
         Y(J) = (X(J) - PSJ)/L(JJ)
 200     CONTINUE
C
      LSVMIN = ONE/V2NORM(P, Y)
      GO TO 999
C
 300  LSVMIN = ZERO
 999  RETURN
C  ***  LAST CARD OF LSVMIN FOLLOWS  ***
      END
      SUBROUTINE LTSQAR(N, A, L)                                        LTS00010
C
C  ***  SET A TO LOWER TRIANGLE OF (L**T) * L  ***
C
C  ***  L = N X N LOWER TRIANG. MATRIX STORED ROWWISE.  ***
C  ***  A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L.  ***
C
      INTEGER N
      REAL A(1), L(1)
C     DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
C
      INTEGER I, II, IIM1, I1, J, K, M
      REAL LII, LJ
C
      II = 0
      DO 50 I = 1, N
         I1 = II + 1
         II = II + I
         M = 1
         IF (I .EQ. 1) GO TO 30
         IIM1 = II - 1
         DO 20 J = I1, IIM1
              LJ = L(J)
              DO 10 K = I1, J
                   A(M) = A(M) + LJ*L(K)
                   M = M + 1
 10                CONTINUE
 20           CONTINUE
 30      LII = L(II)
         DO 40 J = I1, II
 40           A(J) = LII * L(J)
 50      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF LTSQAR FOLLOWS  ***
      END
      SUBROUTINE PARCHK(IV, N, NN, P, V)                                PAR00010
C
C  ***  CHECK NL2SOL (VERSION 2.2) PARAMETERS, PRINT CHANGED VALUES  ***
C
      INTEGER IV(1), N, NN, P
      REAL V(1)
C     DIMENSION IV(*), V(*)
C
      EXTERNAL DFAULT, RMDCON, VCOPY
      REAL RMDCON
C DFAULT -- SUPPLIES DFAULT PARAMETER VALUES.
C RMDCON -- RETURNS MACHINE-DEPENDENT CONSTANTS.
C VCOPY  -- COPIES ONE VECTOR TO ANOTHER.
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IV1, JTOLP, K, L, M, NVDFLT, PU
C/6
      REAL CNGD(3), DFLT(3), VN(2,27), WHICH(3)
C/7
C     CHARACTER*4 CNGD(3), DFLT(3), VN(2,27), WHICH(3)
C/
      REAL BIG, MACHEP, TINY, VK, VM(27), VX(27), ZERO
C
C  ***  IV AND V SUBSCRIPTS  ***
C
      INTEGER DTYPE, DTYPE0, D0INIT, EPSLON, INITS, JTINIT, JTOL0,
     1        JTOL1, OLDN, OLDNN, OLDP, PARPRT, PARSV1, PRUNIT
C
C/6
      DATA NVDFLT/27/, ZERO/0.E+0/
C/7
C     PARAMETER (NVDFLT=27, ZERO=0.D+0)
C/
C
C/6
      DATA DTYPE/16/, DTYPE0/29/, D0INIT/37/, EPSLON/19/,
     1     INITS/25/, JTINIT/39/, JTOL0/86/, JTOL1/87/,
     2     OLDN/45/, OLDNN/46/, OLDP/47/, PARPRT/20/,
     3     PARSV1/51/, PRUNIT/21/
C/7
C     PARAMETER (DTYPE=16, DTYPE0=29, D0INIT=37, EPSLON=19,
C    1     INITS=25, JTINIT=39, JTOL0=86, JTOL1=87,
C    2     OLDN=45, OLDNN=46, OLDP=47, PARPRT=20,
C    3     PARSV1=51, PRUNIT=21)
C     SAVE BIG, TINY
C/
C
      DATA BIG/0.E+0/, TINY/1.E+0/
C/6
      DATA VN(1,1),VN(2,1)/4HEPSL,4HON../
      DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../
      DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../
      DATA VN(1,4),VN(2,4)/4HDECF,4HAC../
      DATA VN(1,5),VN(2,5)/4HINCF,4HAC../
      DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../
      DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../
      DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../
      DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../
      DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../
      DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../
      DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../
      DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../
      DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../
      DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../
      DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../
      DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../
      DATA VN(1,18),VN(2,18)/4HDLTF,4HDJ../
      DATA VN(1,19),VN(2,19)/4HD0IN,4HIT../
      DATA VN(1,20),VN(2,20)/4HDINI,4HT.../
      DATA VN(1,21),VN(2,21)/4HJTIN,4HIT../
      DATA VN(1,22),VN(2,22)/4HDLTF,4HDC../
      DATA VN(1,23),VN(2,23)/4HDFAC,4H..../
      DATA VN(1,24),VN(2,24)/4HRLIM,4HIT../
      DATA VN(1,25),VN(2,25)/4HCOSM,4HIN../
      DATA VN(1,26),VN(2,26)/4HDELT,4HA0../
      DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../
C/7
C     DATA VN(1,1),VN(2,1)/'EPSL','ON..'/
C     DATA VN(1,2),VN(2,2)/'PHMN','FC..'/
C     DATA VN(1,3),VN(2,3)/'PHMX','FC..'/
C     DATA VN(1,4),VN(2,4)/'DECF','AC..'/
C     DATA VN(1,5),VN(2,5)/'INCF','AC..'/
C     DATA VN(1,6),VN(2,6)/'RDFC','MN..'/
C     DATA VN(1,7),VN(2,7)/'RDFC','MX..'/
C     DATA VN(1,8),VN(2,8)/'TUNE','R1..'/
C     DATA VN(1,9),VN(2,9)/'TUNE','R2..'/
C     DATA VN(1,10),VN(2,10)/'TUNE','R3..'/
C     DATA VN(1,11),VN(2,11)/'TUNE','R4..'/
C     DATA VN(1,12),VN(2,12)/'TUNE','R5..'/
C     DATA VN(1,13),VN(2,13)/'AFCT','OL..'/
C     DATA VN(1,14),VN(2,14)/'RFCT','OL..'/
C     DATA VN(1,15),VN(2,15)/'XCTO','L...'/
C     DATA VN(1,16),VN(2,16)/'XFTO','L...'/
C     DATA VN(1,17),VN(2,17)/'LMAX','0...'/
C     DATA VN(1,18),VN(2,18)/'DLTF','DJ..'/
C     DATA VN(1,19),VN(2,19)/'D0IN','IT..'/
C     DATA VN(1,20),VN(2,20)/'DINI','T...'/
C     DATA VN(1,21),VN(2,21)/'JTIN','IT..'/
C     DATA VN(1,22),VN(2,22)/'DLTF','DC..'/
C     DATA VN(1,23),VN(2,23)/'DFAC','....'/
C     DATA VN(1,24),VN(2,24)/'RLIM','IT..'/
C     DATA VN(1,25),VN(2,25)/'COSM','IN..'/
C     DATA VN(1,26),VN(2,26)/'DELT','A0..'/
C     DATA VN(1,27),VN(2,27)/'FUZZ','....'/
C/
C
      DATA VM(1)/1.0E-3/, VM(2)/-0.99E+0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/,
     1     VM(5)/1.2E+0/, VM(6)/1.E-2/, VM(7)/1.2E+0/, VM(8)/0.E+0/,
     2     VM(9)/0.E+0/, VM(10)/1.E-3/, VM(11)/-1.E+0/, VM(15)/0.E+0/,
     3     VM(16)/0.E+0/, VM(19)/0.E+0/, VM(20)/-10.E+0/, VM(21)/0.E+0/,
     4     VM(23)/0.E+0/, VM(24)/1.E+10/, VM(27)/1.01E+0/
      DATA VX(1)/0.9E+0/, VX(2)/-1.E-3/, VX(3)/1.E+1/, VX(4)/0.8E+0/,
     1     VX(5)/1.E+2/, VX(6)/0.8E+0/, VX(7)/1.E+2/, VX(8)/0.5E+0/,
     2     VX(9)/0.5E+0/, VX(10)/1.E+0/, VX(11)/1.E+0/, VX(14)/0.1E+0/,
     3     VX(15)/1.E+0/, VX(16)/1.E+0/, VX(18)/1.E+0/, VX(22)/1.E+0/,
     4     VX(23)/1.E+0/, VX(25)/1.E+0/, VX(26)/1.E+0/, VX(27)/1.E+2/
C
C/6
      DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/,
     1     DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/
C/7
C     DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/,
C    1     DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/
C/
C
C.......................................................................
C
      IF (IV(1) .EQ. 0) CALL DFAULT(IV, V)
      PU = IV(PRUNIT)
      IV1 = IV(1)
      IF (IV1 .NE. 12) GO TO 30
         IF (NN .GE. N .AND. N .GE. P .AND. P .GE. 1) GO TO 20
              IV(1) = 16
              IF (PU .NE. 0) WRITE(PU,10) NN, N, P
 10           FORMAT(30H0///// BAD NN, N, OR P... NN =,I5,5H, N =,I5,
     1               5H, P =,I5)
              GO TO 999
 20      K = IV(21)
         CALL DFAULT(IV(21), V(33))
         IV(21) = K
         IV(DTYPE0) = IV(DTYPE+20)
         IV(OLDN) = N
         IV(OLDNN) = NN
         IV(OLDP) = P
         WHICH(1) = DFLT(1)
         WHICH(2) = DFLT(2)
         WHICH(3) = DFLT(3)
         GO TO 80
 30   IF (N .EQ. IV(OLDN) .AND. NN .EQ. IV(OLDNN) .AND. P .EQ. IV(OLDP))
     1                       GO TO 50
         IV(1) = 17
         IF (PU .NE. 0) WRITE(PU,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN,
     1                               N, P
 40      FORMAT(30H0///// (NN,N,P) CHANGED FROM (,I5,1H,,I5,1H,,I3,
     1          6H) TO (,I5,1H,,I5,1H,,I3,2H).)
         GO TO 999
C
 50   IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70
         IV(1) = 50
         IF (PU .NE. 0) WRITE(PU,60) IV1
 60      FORMAT(15H0/////  IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 12.)
         GO TO 999
C
 70   WHICH(1) = CNGD(1)
      WHICH(2) = CNGD(2)
      WHICH(3) = CNGD(3)
C
 80   IF (BIG .GT. TINY) GO TO 90
         TINY = RMDCON(1)
         MACHEP = RMDCON(3)
         BIG = RMDCON(6)
         VM(12) = MACHEP
         VX(12) = BIG
         VM(13) = TINY
         VX(13) = BIG
         VM(14) = MACHEP
         VM(17) = TINY
         VX(17) = BIG
         VM(18) = MACHEP
         VX(19) = BIG
         VX(20) = BIG
         VX(21) = BIG
         VM(22) = MACHEP
         VX(24) = RMDCON(5)
         VM(25) = MACHEP
         VM(26) = MACHEP
 90   M = 0
      IF (IV(INITS) .GE. 0 .AND. IV(INITS) .LE. 2) GO TO 110
         M = 18
         IF (PU .NE. 0) WRITE(PU,100) IV(INITS)
 100     FORMAT(25H0/////  INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0,
     1          7H AND 2.)
 110  K = EPSLON
      DO 140 I = 1, NVDFLT
         VK = V(K)
         IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 130
              M = K
              IF (PU .NE. 0) WRITE(PU,120) VN(1,I), VN(2,I), K, VK,
     1                                    VM(I), VX(I)
 120          FORMAT(8H0/////  ,2A4,5H.. V(,I2,3H) =,E11.3,7H SHOULD,
     1               11H BE BETWEEN,E11.3,4H AND,D11.3)
 130     K = K + 1
 140     CONTINUE
C
      IF (IV1 .EQ. 12 .AND. V(JTINIT) .GT. ZERO) GO TO 170
C
C  ***  CHECK JTOL VALUES  ***
C
      JTOLP = JTOL0 + P
      DO 160 I = JTOL1, JTOLP
         IF (V(I) .GT. ZERO) GO TO 160
         K = I - JTOL0
         IF (PU .NE. 0) WRITE(PU,150) K, I, V(I)
 150     FORMAT(12H0///// JTOL(,I3,6H) = V(,I3,3H) =,E11.3,
     1          20H SHOULD BE POSITIVE.)
         M = I
 160     CONTINUE
C
 170  IF (M .EQ. 0) GO TO 180
         IV(1) = M
         GO TO 999
C
 180  IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999
      IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. 0) GO TO 200
         M = 1
         WRITE(PU,190) IV(INITS)
 190     FORMAT(22H0NONDEFAULT VALUES..../20H INITS..... IV(25) =,I3)
 200  IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO  210
         IF (M .EQ. 0) WRITE(PU,215) WHICH
         M = 1
         WRITE(PU,205) IV(DTYPE)
 205     FORMAT(20H DTYPE..... IV(16) =,I3)
 210  K = EPSLON
      L = PARSV1
      DO 240 I = 1, NVDFLT
         IF (V(K) .EQ. V(L)) GO TO 230
              IF (M .EQ. 0) WRITE(PU,215) WHICH
 215          FORMAT(1H0,3A4,9HALUES..../)
              M = 1
              WRITE(PU,220) VN(1,I), VN(2,I), K, V(K)
 220          FORMAT(1X,2A4,5H.. V(,I2,3H) =,E15.7)
 230     K = K + 1
         L = L + 1
 240     CONTINUE
      IV(DTYPE0) = IV(DTYPE)
      CALL VCOPY(NVDFLT, V(PARSV1), V(EPSLON))
      IF (IV1 .NE. 12) GO TO 999
         IF (V(JTINIT) .GT. ZERO) GO TO 260
              JTOLP = JTOL0 + P
              WRITE(PU,250) (V(I), I = JTOL1, JTOLP)
 250          FORMAT(24H0(INITIAL) JTOL ARRAY.../(1X,6E12.3))
 260     IF (V(D0INIT) .GT. ZERO) GO TO 999
              K = JTOL1 + P
              L = K + P - 1
              WRITE(PU,270) (V(I), I = K, L)
 270          FORMAT(22H0(INITIAL) D0 ARRAY.../1X,6E12.3)
C
 999  RETURN
C  ***  LAST CARD OF PARCHK FOLLOWS  ***
      END
      SUBROUTINE QAPPLY(NN, N, P, J, R, IERR)                           QAP00010
C     *****PARAMETERS.
      INTEGER NN, N, P, IERR
      REAL J(NN,P), R(N)
C
C     ..................................................................
C     ..................................................................
C
C     *****PURPOSE.
C     THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS
C     STORED IN J BY QRFACT
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN
C             THE CALLING PROGRAM DIMENSION STATEMENT
C
C        N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R
C
C        P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA
C
C        J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS
C             U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
C             IDENT - U*U.TRANSPOSE
C
C        R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL
C             TRANSFORMATIONS WILL BE APPLIED
C
C        IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS
C             WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST
C             ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED
C
C     ON OUTPUT.
C
C        R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     NONE
C
C     *****ALGORITHM NOTES.
C     THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
C     ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2.  THE USE OF
C     THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1).
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C
C     DOTPRD - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS
C
C     *****REFERENCES.
C     (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES
C        SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7,
C        PP. 269-276.
C
C     *****HISTORY.
C     DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977)
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C     *****LOCAL VARIABLES.
      INTEGER I, K, L, NL1
      REAL T
C     *****INTRINSIC FUNCTIONS.
C/+
      INTEGER IABS
C/
C     *****FUNCTIONS.
      EXTERNAL DOTPRD
      REAL DOTPRD
C
      K = P
      IF (IERR .NE. 0) K = IABS(IERR) - 1
      IF ( K .EQ. 0) GO TO 999
C
      DO 20 L = 1, K
         NL1 = N - L + 1
         T = -DOTPRD(NL1, J(L,L), R(L))
C
         DO 10 I = L, N
 10           R(I) = R(I) + T*J(I,L)
 20   CONTINUE
 999  RETURN
C     .... LAST CARD OF QAPPLY .........................................
      END
      SUBROUTINE QRFACT(NM,M,N,QR,ALPHA,IPIVOT,IERR,NOPIVK,SUM)         QRF00010
C
C  ***  COMPUTE THE QR DECOMPOSITION OF THE MATRIX STORED IN QR  ***
C
C     *****PARAMETERS.
      INTEGER NM,M,N,IPIVOT(N),IERR,NOPIVK
      REAL              QR(NM,N),ALPHA(N),SUM(N)
C     *****LOCAL VARIABLES.
      INTEGER I,J,JBAR,K,K1,MINUM,MK1
      REAL              ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL,
     1        RKTOL1,SUMJ
C     *****FUNCTIONS.
C/+
      INTEGER MIN0
      REAL              ABS,SQRT
C/
      EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM
      REAL DOTPRD, RMDCON, V2NORM
C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS.
C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS.
C VAXPY... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C V2NORM... RETURNS THE 2-NORM OF A VECTOR.
C
C     *****CONSTANTS.
      REAL ONE, P01, P99, ZERO
C/6
      DATA ONE/1.0E+0/, P01/0.01E+0/, P99/0.99E+0/, ZERO/0.0E+0/
C/7
C     PARAMETER (ONE=1.0D+0, P01=0.01D+0, P99=0.99D+0, ZERO=0.0D+0)
C     SAVE RKTOL, UFETA
C/
C
C
C     ..................................................................
C     ..................................................................
C
C
C     *****PURPOSE.
C
C     THIS SUBROUTINE DOES A QR-DECOMPOSITION ON THE M X N MATRIX QR,
C        WITH AN OPTIONALLY MODIFIED COLUMN PIVOTING, AND RETURNS THE
C        UPPER TRIANGULAR R-MATRIX, AS WELL AS THE ORTHOGONAL VECTORS
C        USED IN THE TRANSFORMATIONS.
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF THE TWO DIMENSIONAL
C             ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C             DIMENSION STATEMENT.
C
C        M MUST BE SET TO THE NUMBER OF ROWS IN THE MATRIX.
C
C        N MUST BE SET TO THE NUMBER OF COLUMNS IN THE MATRIX.
C
C        QR CONTAINS THE REAL RECTANGULAR MATRIX TO BE DECOMPOSED.
C
C     NOPIVK IS USED TO CONTROL PIVOTTING.  COLUMNS 1 THROUGH
C        NOPIVK WILL REMAIN FIXED IN POSITION.
C
C        SUM IS USED FOR TEMPORARY STORAGE FOR THE SUBROUTINE.
C
C     ON OUTPUT.
C
C        QR CONTAINS THE NON-DIAGONAL ELEMENTS OF THE R-MATRIX
C             IN THE STRICT UPPER TRIANGLE. THE VECTORS U, WHICH
C             DEFINE THE HOUSEHOLDER TRANSFORMATIONS   I - U*U-TRANSP,
C             ARE IN THE COLUMNS OF THE LOWER TRIANGLE. THESE VECTORS U
C             ARE SCALED SO THAT THE SQUARE OF THEIR 2-NORM IS 2.0.
C
C        ALPHA CONTAINS THE DIAGONAL ELEMENTS OF THE R-MATRIX.
C
C        IPIVOT REFLECTS THE COLUMN PIVOTING PERFORMED ON THE INPUT
C             MATRIX TO ACCOMPLISH THE DECOMPOSITION. THE J-TH
C             ELEMENT OF IPIVOT GIVES THE COLUMN OF THE ORIGINAL
C             MATRIX WHICH WAS PIVOTED INTO COLUMN J DURING THE
C             DECOMPOSITION.
C
C        IERR IS SET TO.
C             0 FOR NORMAL RETURN,
C             K IF NO NON-ZERO PIVOT COULD BE FOUND FOR THE K-TH
C                  TRANSFORMATION, OR
C             -K FOR AN ERROR EXIT ON THE K-TH THANSFORMATION.
C             IF AN ERROR EXIT WAS TAKEN, THE FIRST (K - 1)
C             TRANSFORMATIONS ARE CORRECT.
C
C
C     *****APPLICATIONS AND USAGE RESTRICTIONS.
C     THIS MAY BE USED WHEN SOLVING LINEAR LEAST-SQUARES PROBLEMS --
C     SEE SUBROUTINE QR1 OF ROSEPACK.  IT IS CALLED FOR THIS PURPOSE
C     BY LLSQST IN THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE.
C
C     *****ALGORITHM NOTES.
C     THIS VERSION OF QRFACT TRIES TO ELIMINATE THE OCCURRENCE OF
C     UNDERFLOWS DURING THE ACCUMULATION OF INNER PRODUCTS.  RKTOL1
C     IS CHOSEN BELOW SO AS TO INSURE THAT DISCARDED TERMS HAVE NO
C     EFFECT ON THE COMPUTED TWO-NORMS.
C
C     ADAPTED FROM THE ALGOL ROUTINE SOLVE (1).
C
C     *****REFERENCES.
C     (1)     BUSINGER,P. AND GOLUB,G.H., LINEAR LEAST SQUARES
C     SOLUTIONS BY HOUSHOLDER TRANSFORMATIONS, IN WILKINSON,J.H.
C     AND REINSCH,C.(EDS.), HANDBOOK FOR AUTOMATIC COMPUTATION,
C     VOLUME II. LINEAR ALGEBRA, SPRINGER-VERLAG, 111-118 (1971).
C     PREPUBLISHED IN NUMER.MATH. 7, 269-276 (1965).
C
C     *****HISTORY.
C     THIS AMOUNTS TO THE SUBROUTINE QR1 OF ROSEPACK WITH RKTOL1 USED
C     IN PLACE OF RKTOL BELOW, WITH V2NORM USED TO INITIALIZE (AND
C     SOMETIMES UPDATE) THE SUM ARRAY, AND WITH CALLS ON DOTPRD AND
C     VAXPY IN PLACE OF SOME LOOPS.
C
C     *****GENERAL.
C
C     DEVELOPMENT OF THIS PROGRAM SUPPORTED IN PART BY
C     NATIONAL SCIENCE FOUNDATION GRANT GJ-1154X3 AND
C     NATIONAL SCIENCE FOUNDATION GRANT DCR75-08802
C     TO NATIONAL BUREAU OF ECONOMIC RESEARCH, INC.
C
C
C
C     ..................................................................
C     ..................................................................
C
C
C     ..........  UFETA IS THE SMALLEST POSITIVE FLOATING POINT NUMBER
C        S.T. UFETA AND -UFETA CAN BOTH BE REPRESENTED.
C
C     ..........  RKTOL IS THE SQUARE ROOT OF THE RELATIVE PRECISION
C        OF FLOATING POINT ARITHMETIC (MACHEP).
      DATA RKTOL/0.E+0/, UFETA/0.E+0/
C     *****BODY OF PROGRAM.
      IF (UFETA .GT. ZERO) GO TO 10
         UFETA = RMDCON(1)
         RKTOL = RMDCON(4)
   10 IERR = 0
      RKTOL1 = P01 * RKTOL
C
      DO 20 J=1,N
         SUM(J) = V2NORM(M, QR(1,J))
         IPIVOT(J) = J
   20 CONTINUE
C
      MINUM = MIN0(M,N)
C
      DO 120 K=1,MINUM
         MK1 = M - K + 1
C        ..........K-TH HOUSEHOLDER TRANSFORMATION..........
         SIGMA = ZERO
         JBAR = 0
C        ..........FIND LARGEST COLUMN SUM..........
      IF (K .LE. NOPIVK) GO TO 50
         DO 30 J=K,N
              IF (SIGMA .GE. SUM(J))  GO TO 30
              SIGMA = SUM(J)
              JBAR = J
   30    CONTINUE
C
         IF (JBAR .EQ. 0)  GO TO 220
         IF (JBAR .EQ. K)  GO TO 50
C        ..........COLUMN INTERCHANGE..........
         I = IPIVOT(K)
         IPIVOT(K) = IPIVOT(JBAR)
         IPIVOT(JBAR) = I
         SUM(JBAR) = SUM(K)
         SUM(K) = SIGMA
C
         DO 40 I=1,M
              SIGMA = QR(I,K)
              QR(I,K) = QR(I,JBAR)
              QR(I,JBAR) = SIGMA
   40    CONTINUE
C        ..........END OF COLUMN INTERCHANGE..........
   50    CONTINUE
C        ..........  SECOND INNER PRODUCT  ..........
         QRKMAX = ZERO
C
         DO 60 I=K,M
              IF (ABS( QR(I,K) ) .GT. QRKMAX)  QRKMAX = ABS( QR(I,K) )
   60    CONTINUE
C
         IF (QRKMAX .LT. UFETA)  GO TO 210
         ALPHAK = V2NORM(MK1, QR(K,K)) / QRKMAX
         SIGMA = ALPHAK**2
C
C        ..........  END SECOND INNER PRODUCT  ..........
         QRKK = QR(K,K)
         IF (QRKK .GE. ZERO)  ALPHAK = -ALPHAK
         ALPHA(K) = ALPHAK * QRKMAX
         BETA = QRKMAX * SQRT(SIGMA - (QRKK*ALPHAK/QRKMAX) )
         QR(K,K) = QRKK - ALPHA(K)
         DO 65 I=K,M
   65         QR(I,K) =  QR(I,K) / BETA
         K1 = K + 1
         IF (K1 .GT. N) GO TO 120
C
         DO 110 J = K1, N
              TEMP = -DOTPRD(MK1, QR(K,K), QR(K,J))
C
C             ***  SET QR(I,J) = QR(I,J) + TEMP*QR(I,K), I = K,...,M.
C
              CALL VAXPY(MK1, QR(K,J), TEMP, QR(K,K), QR(K,J))
C
              IF (K1 .GT. M) GO TO 110
              SUMJ = SUM(J)
              IF (SUMJ .LT. UFETA) GO TO 110
              TEMP = ABS(QR(K,J)/SUMJ)
              IF (TEMP .LT. RKTOL1) GO TO 110
              IF (TEMP .GE. P99) GO TO 90
                   SUM(J) = SUMJ * SQRT(ONE - TEMP**2)
                   GO TO 110
   90         SUM(J) = V2NORM(M-K, QR(K1,J))
  110    CONTINUE
C        ..........END OF K-TH HOUSEHOLDER TRANSFORMATION..........
  120 CONTINUE
C
      GO TO 999
C     ..........ERROR EXIT ON K-TH TRANSFORMATION..........
  210 IERR = -K
      GO TO 230
C     ..........NO NON-ZERO ACCEPTABLE PIVOT FOUND..........
  220 IERR = K
  230 DO 240 I = K, N
         ALPHA(I) = ZERO
         IF (I .GT. K) CALL VSCOPY(I-K, QR(K,I), ZERO)
 240     CONTINUE
C     ..........RETURN TO CALLER..........
  999 RETURN
C     ..........LAST CARD OF QRFACT..........
      END
      REAL FUNCTION RELDST(P, D, X, X0)                                 REL00010
C
C  ***  COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0  ***
C  ***  NL2SOL VERSION 2.2  ***
C
      INTEGER P
      REAL D(P), X(P), X0(P)
C/+
      REAL ABS
C/
      INTEGER I
      REAL EMAX, T, XMAX, ZERO
C/6
      DATA ZERO/0.E+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
      EMAX = ZERO
      XMAX = ZERO
      DO 10 I = 1, P
         T = ABS(D(I) * (X(I) - X0(I)))
         IF (EMAX .LT. T) EMAX = T
         T = D(I) * (ABS(X(I)) + ABS(X0(I)))
         IF (XMAX .LT. T) XMAX = T
 10      CONTINUE
      RELDST = ZERO
      IF (XMAX .GT. ZERO) RELDST = EMAX / XMAX
 999  RETURN
C  ***  LAST CARD OF RELDST FOLLOWS  ***
      END
      SUBROUTINE RPTMUL(FUNC, IPIVOT, J, NN, P, RD, X, Y, Z)            RPT00010
C
C  ***  FUNC = 1... SET  Y = RMAT * (PERM**T) * X.
C  ***  FUNC = 2... SET  Y = PERM * (RMAT**T) * RMAT * (PERM**T) * X.
C  ***  FUNC = 3... SET  Y = PERM * (RMAT**T) X.
C
C
C  ***  PERM = MATRIX WHOSE I-TH COL. IS THE IPIVOT(I)-TH UNIT VECTOR.
C  ***  RMAT IS THE UPPER TRIANGULAR MATRIX WHOSE STRICT UPPER TRIANGLE
C  ***       IS STORED IN  J  AND WHOSE DIAGONAL IS STORED IN RD.
C  ***  Z IS A SCRATCH VECTOR.
C  ***  X AND Y MAY SHARE STORAGE.
C
      INTEGER FUNC, NN, P
      INTEGER IPIVOT(P)
      REAL J(NN,P), RD(P), X(P), Y(P), Z(P)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IM1, K, KM1
      REAL ZK
C
C  ***  EXTERNAL FUNCTION  ***
C
      EXTERNAL DOTPRD
      REAL DOTPRD
C
C-----------------------------------------------------------------------
C
      IF (FUNC .GT. 2) GO TO 50
C
C  ***  FIRST SET  Z = (PERM**T) * X  ***
C
      DO 10 I = 1, P
         K = IPIVOT(I)
         Z(I) = X(K)
 10      CONTINUE
C
C  ***  NOW SET  Y = RMAT * Z  ***
C
      Y(1) = Z(1) * RD(1)
      IF (P .LE. 1) GO TO 40
      DO 30 K = 2, P
         KM1 = K - 1
         ZK = Z(K)
         DO 20 I = 1, KM1
 20           Y(I) = Y(I) + J(I,K)*ZK
         Y(K) = ZK*RD(K)
 30      CONTINUE
C
 40   IF (FUNC .LE. 1) GO TO 999
      GO TO 70
C
 50   DO 60 I = 1, P
 60      Y(I) = X(I)
C
C  ***  SET  Z = (RMAT**T) * Y  ***
C
 70   Z(1) = Y(1) * RD(1)
      IF (P .EQ. 1) GO TO 90
      DO 80 I = 2, P
         IM1 = I - 1
         Z(I) = Y(I)*RD(I) + DOTPRD(IM1, J(1,I), Y)
 80      CONTINUE
C
C  ***  NOW SET  Y = PERM * Z  ***
C
 90   DO 100 I = 1, P
         K = IPIVOT(I)
         Y(K) = Z(I)
 100     CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF RPTMUL FOLLOWS  ***
      END
      SUBROUTINE SLUPDT(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, SLU00010
     1                  Y)
C
C  ***  UPDATE SYMMETRIC  A  SO THAT  A * STEP = Y  ***
C  ***  (LOWER TRIANGLE OF  A  STORED ROWWISE       ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      REAL A(1), COSMIN, SIZE, STEP(P), U(P), W(P),
     1                 WCHMTD(P), WSCALE, Y(P)
C     DIMENSION A(P*(P+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, J, K
      REAL DENMIN, SDOTWM, T, UI, WI
C
C     ***  CONSTANTS  ***
      REAL HALF, ONE, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      REAL ABS, AMIN1
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DOTPRD, SLVMUL, V2NORM
      REAL DOTPRD, V2NORM
C
C/6
      DATA HALF/0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0)
C/
C
C-----------------------------------------------------------------------
C
      SDOTWM = DOTPRD(P, STEP, WCHMTD)
      DENMIN = COSMIN * V2NORM(P,STEP) * V2NORM(P,WCHMTD)
      WSCALE = ONE
      IF (DENMIN .NE. ZERO) WSCALE = AMIN1(ONE, ABS(SDOTWM/DENMIN))
      T = ZERO
      IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM
      DO 10 I = 1, P
 10      W(I) = T * WCHMTD(I)
      CALL SLVMUL(P, U, A, STEP)
      T = HALF * (SIZE * DOTPRD(P, STEP, U)  -  DOTPRD(P, STEP, Y))
      DO 20 I = 1, P
 20      U(I) = T*W(I) + Y(I) - SIZE*U(I)
C
C  ***  SET  A = A + U*(W**T) + W*(U**T)  ***
C
      K = 1
      DO 40 I = 1, P
         UI = U(I)
         WI = W(I)
         DO 30 J = 1, I
              A(K) = SIZE*A(K) + UI*W(J) + WI*U(J)
              K = K + 1
 30           CONTINUE
 40      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF SLUPDT FOLLOWS  ***
      END
      SUBROUTINE SLVMUL(P, Y, S, X)                                     SLV00010
C
C  ***  SET  Y = S * X,  S = P X P SYMMETRIC MATRIX.  ***
C  ***  LOWER TRIANGLE OF  S  STORED ROWWISE.         ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      REAL S(1), X(P), Y(P)
C     DIMENSION S(P*(P+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IM1, J, K
      REAL XI
C
C  ***  NO INTRINSIC FUNCTIONS  ***
C
C  ***  EXTERNAL FUNCTION  ***
C
      EXTERNAL DOTPRD
      REAL DOTPRD
C
C-----------------------------------------------------------------------
C
      J = 1
      DO 10 I = 1, P
         Y(I) = DOTPRD(I, S(J), X)
         J = J + I
 10      CONTINUE
C
      IF (P .LE. 1) GO TO 999
      J = 1
      DO 40 I = 2, P
         XI = X(I)
         IM1 = I - 1
         J = J + 1
         DO 30 K = 1, IM1
              Y(K) = Y(K) + S(J)*XI
              J = J + 1
 30           CONTINUE
 40      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF SLVMUL FOLLOWS  ***
      END
      LOGICAL FUNCTION STOPX(IDUMMY)                                    STO00010
C     *****PARAMETERS...
      INTEGER IDUMMY
C
C     ..................................................................
C
C     *****PURPOSE...
C     THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION)
C     FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT
C     THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A
C     DYNAMIC STOPX.
C
C     *****ALGORITHM NOTES...
C     AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED
C     INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A
C     FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT
C     (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX.
C
C     ..................................................................
C
      STOPX = .FALSE.
      RETURN
      END
      SUBROUTINE VAXPY(P, W, A, X, Y)                                   VAX00010
C
C  ***  SET W = A*X + Y  --  W, X, Y = P-VECTORS, A = SCALAR  ***
C
      INTEGER P
      REAL A, W(P), X(P), Y(P)
C
      INTEGER I
C
      DO 10 I = 1, P
 10      W(I) = A*X(I) + Y(I)
      RETURN
      END
      SUBROUTINE VCOPY(P, Y, X)                                         VCO00010
C
C  ***  SET Y = X, WHERE X AND Y ARE P-VECTORS  ***
C
      INTEGER P
      REAL X(P), Y(P)
C
      INTEGER I
C
      DO 10 I = 1, P
 10      Y(I) = X(I)
      RETURN
      END
      SUBROUTINE VSCOPY(P, Y, S)                                        VSC00010
C
C  ***  SET P-VECTOR Y TO SCALAR S  ***
C
      INTEGER P
      REAL S, Y(P)
C
      INTEGER I
C
      DO 10 I = 1, P
 10      Y(I) = S
      RETURN
      END
      REAL FUNCTION V2NORM(P, X)                                        V2N00010
C
C  ***  RETURN THE 2-NORM OF THE P-VECTOR X, TAKING  ***
C  ***  CARE TO AVOID THE MOST LIKELY UNDERFLOWS.    ***
C
      INTEGER P
      REAL X(P)
C
      INTEGER I, J
      REAL ONE, R, SCALE, SQTETA, T, XI, ZERO
C/+
      REAL ABS, SQRT
C/
      EXTERNAL RMDCON
      REAL RMDCON
C
C/6
      DATA ONE/1.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C     SAVE SQTETA
C/
      DATA SQTETA/0.E+0/
C
      IF (P .GT. 0) GO TO 10
         V2NORM = ZERO
         GO TO 999
 10   DO 20 I = 1, P
         IF (X(I) .NE. ZERO) GO TO 30
 20      CONTINUE
      V2NORM = ZERO
      GO TO 999
C
 30   SCALE = ABS(X(I))
      IF (I .LT. P) GO TO 40
         V2NORM = SCALE
         GO TO 999
 40   T = ONE
      IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2)
C
C     ***  SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE
C     ***  SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE.
C     ***  THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS.
C
      J = I + 1
      DO 60 I = J, P
         XI = ABS(X(I))
         IF (XI .GT. SCALE) GO TO 50
              R = XI / SCALE
              IF (R .GT. SQTETA) T = T + R*R
              GO TO 60
 50           R = SCALE / XI
              IF (R .LE. SQTETA) R = ZERO
              T = ONE  +  T * R*R
         SCALE = XI
 60      CONTINUE
C
      V2NORM = SCALE * SQRT(T)
 999  RETURN
C  ***  LAST CARD OF V2NORM FOLLOWS  ***
      END
C///////////////////////////////////////////////////////////////////////
C  ***  RUN NL2SOL ON VARIOUS TEST PROBLEMS, PRINT SUMMARY STATISTICS.  NLM00010
C
C     *****COMMON STORAGE WITH NLTEST.
C
      COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV
      COMMON /TESTCH/ NAME, IRC
      INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2
      REAL RS(5,50)
C/6
      REAL NAME(2,50)
      INTEGER IRC(50)
C/7
C     CHARACTER NAME(2,50)*4, IRC(50)*1
C/
      REAL V(1736)
C
C
C     ..................................................................
C
C     *****PURPOSE.
C        THIS MAIN PROGRAM CALLS NLTEST TO RUN NL2SOL, THE NONLINEAR
C     LEAST-SQUARES SOLVER OF REF. 1, ON VARIOUS TEST PROBLEMS.
C
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     THIS MAIN DRIVER IS INTENDED TO CHECK WHETHER THE NL2SOL
C     (NONLINEAR LEAST-SQUARES) PACKAGE WAS SUCCESSFULLY
C     TRANSPORTED TO A NEW MACHINE.
C
C     *****ALGORITHM NOTES.
C     THE TEST PROBLEMS USED ARE FROM REFERENCES (2), (3), AND (4).
C     SOME ADDITIONAL TEST PROBLEMS WERE SUGGESTED BY JORGE MORE (PRI-
C     VATE COMMUNICATION).  CALLS PASSING THESE PROBLEMS TO NLTEST HAVE
C     BEEN COMMENTED OUT (SINCE THERE ARE ENOUGH OTHER PROBLEMS), BUT
C     NOT REMOVED, SINCE THEY MAY BE OF INTEREST TO OTHER RESEARCHERS.
C
C     *****FUNCTIONS AND SUBROUTINES CALLED.
C
C        DFAULT - ESTABLISHES THE DEFAULT PARAMETER SETTINGS FOR
C                 IV AND V.
C
C        IMDCON - IMDCON(2) RETURNS I/O UNIT NUMBER ON WHICH NLTEST
C                  WRITES A SUMMARY OF EACH TEST RUN.
C
C        IVVSET - SUPPLIES NONDEFAULT VALUES FOR IV AND V.
C
C        NLTEST - CALLS NL2SOL, THE NONLINEAR LEAST-SQUARES
C                  PROBLEM SOLVER.
C
C        TODAY  - SUPPLIES DATE AND TIME (OR CURRENT VERSION OF NL2SOL).
C
C     *****REFERENCES.
C
C     (1). DENNIS, J.E.. GAY, D.M.. AND WELSCH, R.E. (1980),
C          AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
C          SUBMITTED TO ACM TRANS. MATH. SOFTWARE.
C          UNDER REVISION.
C
C     (2). GILL, P.E.. AND MURRAY, W. (1976),ALGORITHMS FOR THE
C          SOLUTION OF THE NON-LINEAR LEAST-SQUARES PROBLEM,
C          NPL REPORT NAC71,(NATIONAL PHYSICAL LABORATORY,
C          DIVISION OF NUMERICAL ANALYSIS AND COMPUTING,
C          TEDDINGTON,MIDDLESEX,ENGLAND).
C
C     (3) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS
C        OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING,
C        EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER,
C        ACADEMIC PRESS, NEW YORK.
C
C     (4) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON-
C        LIKE METHOD BASED UPON GAUSSIAN ELIMINATION,
C        SIAM J. NUMER. ANAL. 6, PP. 560-569.
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C     *****INTRINSIC FUNCTIONS.
C/+
      INTEGER MOD
      REAL AMAX1
C/
C     *****EXTERNAL FUNCTIONS AND SUBROUTINES.
      EXTERNAL DFAULT, IMDCON, IVVSET, NLTEST, TODAY
      INTEGER IMDCON
C
C     *****LOCAL VARIABLES.
      LOGICAL RSTART
      INTEGER I, J, K, MXFCSV, MXITSV, PU
C/6
      INTEGER JTYP(2)
      REAL DATIME(4)
C/7
C     CHARACTER DATIME(4)*4, JTYP(2)*1
C/
C
C/6
      DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/1H ,1H*/
C/7
C     DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/' ','*'/
C/
C
C-----------------------------------------------------------------------
C
C  ***  ESTABLISH DEFAULT PARAMETER SETTINGS  ***
      CALL DFAULT (IV, V)
      NOUT = IMDCON(2)
C
C  ***  NON-DEFAULT PARAMETER SETTINGS  ***
C
      CALL IVVSET(IV, V)
      PU = IV(21)
C
      JAC = 1
      NPROB = 0
      XSCAL1 = 1
      XSCAL2 = 3
C
C/6
      CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART)
      CALL NLTEST(3,3,2,4HHELI,4HX   ,RSTART)
      CALL NLTEST(4,4,3,4HSING,4HULAR,RSTART)
      CALL NLTEST(7,4,4,4HWOOD,4HS   ,RSTART)
      XSCAL2 = 1
      CALL NLTEST(3,3,5,4HZANG,4HWILL,RSTART)
      XSCAL2 = 3
      CALL NLTEST(5,3,6,4HENGV,4HALL ,RSTART)
      CALL NLTEST(2,2,7,4HBRAN,4HIN  ,RSTART)
      XSCAL2 = 2
      CALL NLTEST(3,2,8,4HBEAL,4HE   ,RSTART)
      CALL NLTEST(5,4,9,4HCRAG,4HG   ,RSTART)
      XSCAL2 = 2
      CALL NLTEST(10,3,10,4HBOX ,4H    ,RSTART)
      MXFCSV = IV(17)
      MXITSV = IV(18)
      IV(17) = 20
      IV(18) = 15
      XSCAL2 = 1
      CALL NLTEST(15,15,11,4HDAVI,4HDON1,RSTART)
      IV(17) = MXFCSV
      IV(18) = MXITSV
      XSCAL2 = 3
      CALL NLTEST(2,2,12,4HFRDS,4HTEIN,RSTART)
      XSCAL2 = 1
      CALL NLTEST(31,6,13,4HWATS,4HON6 ,RSTART)
      CALL NLTEST(31,9,14,4HWATS,4HON9 ,RSTART)
      CALL NLTEST(31,12,15,4HWATS,4HON12,RSTART)
      MXFCSV = IV(17)
      IV(17) = 20
      MXITSV = IV(18)
      IV(18) = 15
      CALL NLTEST(31,20,16,4HWATS,4HON20,RSTART)
      IV(17) = MXFCSV
      IV(18) = MXITSV
      XSCAL2 = 2
      CALL NLTEST(8,8,17,4HCHEB,4HQD8 ,RSTART)
      XSCAL2 = 3
      CALL NLTEST(20,4,18,4HBROW,4HN   ,RSTART)
      CALL NLTEST(15,3,19,4HBARD,4H    ,RSTART)
      XSCAL2 = 1
      CALL NLTEST(10,2,20,4HJENN,4HRICH,RSTART)
      XSCAL2 = 3
      CALL NLTEST(11,4,21,4HKOWA,4HLIK ,RSTART)
      XSCAL2 = 1
      CALL NLTEST(33,5,22,4HOSBO,4HRNE1,RSTART)
      XSCAL2 = 2
      CALL NLTEST(65,11,23,4HOSBO,4HRNE2,RSTART)
      XSCAL2 = 3
      CALL NLTEST(3,2,24,4HMADS,4HEN  ,RSTART)
      XSCAL2 = 1
      IV(17) = 400
      IV(18) = 300
      CALL NLTEST(16,3,25,4HMEYE,4HR   ,RSTART)
C/7
C     CALL NLTEST(2,2,1,'ROSN','BROK',RSTART)
C     CALL NLTEST(3,3,2,'HELI','X   ',RSTART)
C     CALL NLTEST(4,4,3,'SING','ULAR',RSTART)
C     CALL NLTEST(7,4,4,'WOOD','S   ',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(3,3,5,'ZANG','WILL',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(5,3,6,'ENGV','ALL ',RSTART)
C     CALL NLTEST(2,2,7,'BRAN','IN  ',RSTART)
C     XSCAL2 = 2
C     CALL NLTEST(3,2,8,'BEAL','E   ',RSTART)
C     CALL NLTEST(5,4,9,'CRAG','G   ',RSTART)
C     XSCAL2 = 2
C     CALL NLTEST(10,3,10,'BOX ','    ',RSTART)
C     MXFCSV = IV(17)
C     MXITSV = IV(18)
C     IV(17) = 20
C     IV(18) = 15
C     XSCAL2 = 1
C     CALL NLTEST(15,15,11,'DAVI','DON1',RSTART)
C     IV(17) = MXFCSV
C     IV(18) = MXITSV
C     XSCAL2 = 3
C     CALL NLTEST(2,2,12,'FRDS','TEIN',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(31,6,13,'WATS','ON6 ',RSTART)
C     CALL NLTEST(31,9,14,'WATS','ON9 ',RSTART)
C     CALL NLTEST(31,12,15,'WATS','ON12',RSTART)
C     MXFCSV = IV(17)
C     IV(17) = 20
C     MXITSV = IV(18)
C     IV(18) = 15
C     CALL NLTEST(31,20,16,'WATS','ON20',RSTART)
C     IV(17) = MXFCSV
C     IV(18) = MXITSV
C     XSCAL2 = 2
C     CALL NLTEST(8,8,17,'CHEB','QD8 ',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(20,4,18,'BROW','N   ',RSTART)
C     CALL NLTEST(15,3,19,'BARD','    ',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(10,2,20,'JENN','RICH',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(11,4,21,'KOWA','LIK ',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(33,5,22,'OSBO','RNE1',RSTART)
C     XSCAL2 = 2
C     CALL NLTEST(65,11,23,'OSBO','RNE2',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(3,2,24,'MADS','EN  ',RSTART)
C     XSCAL2 = 1
C     IV(17) = 400
C     IV(18) = 300
C     CALL NLTEST(16,3,25,'MEYE','R   ',RSTART)
C/
C  ***  BROWN5  ***
C     CALL NLTEST(5,5,26,4HBROW,4HN5  ,RSTART)
C  ***  BROWN10  ***
C     CALL NLTEST(10,10,27,4HBROW,4HN10 ,RSTART)
C  ***  BROWN30  ***
C     CALL NLTEST(30,30,28,4HBROW,4HN30 ,RSTART)
C  ***  BROWN40  ***
C     CALL NLTEST(40,40,29,4HBROW,4HN40 ,RSTART)
C  ***  BARD+10 ***
C     CALL NLTEST(15,3,30,4HBARD,4H+10 ,RSTART)
C  ***  KOWALIK AND OSBORNE + 10  ***
C     CALL NLTEST(11,4,31,4HKOWA,4HL+10,RSTART)
C  ***  MEYER + 10  ***
C     CALL NLTEST(16,3,32,4HMEYE,4HR+10,RSTART)
C  ***  WATSON6 + 10  ***
C     CALL NLTEST(31,6,33,4HWAT6,4H+10 ,RSTART)
C  ***  WATSON9 + 10  ***
C     CALL NLTEST(31,9,34,4HWAT9,4H+10 ,RSTART)
C  ***  WATSON12 + 10  ***
C     CALL NLTEST(31,12,35,4HWAT1,4H2+10,RSTART)
C  ***  WATSON20 + 10  ***
C     CALL NLTEST(31,20,36,4HWAT2,4H0+10,RSTART)
C
C  ***  REPEAT TWO TESTS USING FINITE-DIFFERENCE JACOBIAN  ***
C
      JAC = 2
      XSCAL2 = 1
C
      IV(17) = 50
      IV(18) = 40
C/6
      CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART)
C/7
C     CALL NLTEST(2,2,1,'ROSN','BROK',RSTART)
C/
      V(29) = AMAX1(1.0E-7, V(29))
      IV(17) = 30
      IV(18) = 20
C  ***  BROWN  ***
C/6
      CALL NLTEST(20,4,18,4HBROW,4HN   ,RSTART)
C/7
C     CALL NLTEST(20,4,18,'BROW','N   ',RSTART)
C/
C
      IF (NPROB .EQ. 0 .OR. PU .EQ. 0) STOP
      CALL TODAY(DATIME)
      DO 130 K = 1, NPROB
         IF (MOD(K,56) .EQ. 1) WRITE(PU, 110) DATIME, NPROB
 110     FORMAT(1H1,11X,2A4,2X,2A4,10X,10HSUMMARY OF,I4,
     1          22H NL2SOL TEST RUNS.....,10X,
     2          32H(* = FINITE-DIFFERENCE JACOBIAN)/
     3          48H0 PROBLEM    N   P  NITER   NF   NG  IV1  X0SCAL,5X,
     4          39HFINAL F     PRELDF     NRELDF     RELDX/)
         J = IS(6,K)
         WRITE(PU,120) JTYP(J), NAME(1,K), NAME(2,K),
     1                 (IS(I,K), I=1,5), IRC(K), (RS(I,K), I=1,5)
 120     FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3)
 130     CONTINUE
C
      STOP
C...... LAST CARD OF NLMAIN ............................................
      END
      SUBROUTINE IVVSET(IV, V)                                          IVV00010
C
C  ***  SUPPLY NONDEFAULT IV AND V VALUES FOR NLMAIN  (NL2SOL VER. 2.2).
C
      INTEGER IV(24)
      REAL V(100)
C
C     ACTIVATE THE NEXT LINE TO TURN OFF DETAILED SUMMARY PRINTING
C     IV(21) = 0
      RETURN
      END
      SUBROUTINE NLTEST (N, P, NEX, TITLE1, TITLE2, RSTART)             NLT00010
C
C  ***  CALL NL2SOL, SAVE AND PRINT STATISTICS  ***
C
C
      INTEGER N, P, NEX
      LOGICAL RSTART
C/6
      REAL TITLE1, TITLE2
C/7
C     CHARACTER*4 TITLE1, TITLE2
C/
C
      COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV
      COMMON /TESTCH/ NAME, IRC
      INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2
      REAL RS(5,50)
C/6
      INTEGER IRC(50)
      REAL NAME(2,50)
C/7
C     CHARACTER NAME(2,50)*4, IRC(50)*1
C/
      REAL V(1736)
C
      LOGICAL RSTRT
      INTEGER I, IRUN, PU, UIP(1)
C/6
      INTEGER ALG(2), JTYP(2), RC(10)
      REAL DATIME(4)
C/7
C     CHARACTER*4 DATIME(4)
C     CHARACTER*2 ALG(2)
C     CHARACTER*1 JTYP(2), RC(10)
C/
      REAL ONE, T, URPARM(1), X(20), X0SCAL, ZERO
C
C     ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL NL2SNO, NL2SOL, TESTR, TESTJ, TODAY, XINIT
C
C  ***  IV AND V SUBSCRIPTS  ***
C
      INTEGER F, F0, NFCALL, NFCOV, NGCALL, NITER, NREDUC, PREDUC,
     1        PRUNIT, RELDX
C
C/6
      DATA F/10/, F0/13/, NFCALL/6/, NFCOV/40/, NGCALL/30/,
     1     NGCOV/41/, NITER/31/, NREDUC/6/, PREDUC/7/,
     2     PRUNIT/21/, RELDX/17/
C/7
C     PARAMETER (F=10, F0=13, NFCALL=6, NFCOV=40, NGCALL=30,
C    1     NGCOV=41, NITER=31, NREDUC=6, PREDUC=7,
C    2     PRUNIT=21, RELDX=17)
C/
C/6
      DATA ONE/1.E+0/, ZERO/0.E+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C/
C/6
      DATA ALG(1),ALG(2)/2HOL,2HNO/, JTYP(1),JTYP(2)/1H ,1H*/
      DATA RC(1)/1H./, RC(2)/1H+/, RC(3)/1HX/, RC(4)/1HR/, RC(5)/1HB/,
     1     RC(6)/1HA/, RC(7)/1HS/, RC(8)/1HF/, RC(9)/1HE/, RC(10)/1HI/
C/7
C     DATA ALG(1),ALG(2)/'OL','NO'/, JTYP(1),JTYP(2)/' ','*'/
C     DATA RC(1)/'.'/, RC(2)/'+'/, RC(3)/'X'/, RC(4)/'R'/, RC(5)/'B'/,
C    1     RC(6)/'A'/, RC(7)/'S'/, RC(8)/'F'/, RC(9)/'E'/, RC(10)/'I'/
C/
C
C-----------------------------------------------------------------------
C
      UIP(1) = NEX
      RSTRT = RSTART
      IF (RSTRT) GO TO 20
         PU = IV(PRUNIT)
         CALL TODAY(DATIME)
         IF (PU .NE. 0) WRITE(PU,10) ALG(JAC), TITLE1, TITLE2, DATIME
 10      FORMAT (1H1//11H ***** NL2S,A2,12H ON PROBLEM ,2A4,6H *****,6X,
     1           2A4,2X,2A4)
C
 20   DO 100 IRUN = XSCAL1, XSCAL2
         IF (RSTRT) GO TO 40
         IV(1) = 12
         X0SCAL = 1.0E1 ** (IRUN-1)
C
C        ***  INITIALIZE THE SOLUTION VECTOR X  ***
         CALL XINIT(P, X, NEX)
         DO 30 I = 1, P
 30           X(I) = X0SCAL * X(I)
C
 40      IF (JAC .EQ. 1)
     1             CALL NL2SOL(N,P,X,TESTR,TESTJ,IV,V,UIP,URPARM,TESTR)
         IF (JAC .EQ. 2)
     1             CALL NL2SNO(N,P,X,TESTR,IV,V,UIP,URPARM,TESTR)
         IF (.NOT. RSTRT .AND. NPROB .LT. 50) NPROB = NPROB + 1
         NAME(1,NPROB) = TITLE1
         NAME(2,NPROB) = TITLE2
         IS(1,NPROB) = N
         IS(2,NPROB) = P
         IS(3,NPROB) = IV(NITER)
         IS(4,NPROB) = IV(NFCALL) - IV(NFCOV)
         IS(5,NPROB) = IV(NGCALL) - IV(NGCOV)
         I = IV(1)
         IRC(NPROB) = RC(I)
         IS(6,NPROB) = JAC
         RS(1,NPROB) = X0SCAL
         RS(2,NPROB) = V(F)
         T = ONE
         IF (V(F0) .GT. ZERO) T = V(PREDUC) / V(F0)
         RS(3,NPROB) = T
         T = ONE
         IF (V(F0) .GT. ZERO) T = V(NREDUC) / V(F0)
         RS(4,NPROB) = T
         RS(5,NPROB) = V(RELDX)
         RSTRT = .FALSE.
         IF (NOUT .EQ. 0) GO TO 100
         IF (NPROB .EQ. 1) WRITE(NOUT,50) DATIME
 50      FORMAT(1H1,11X,2A4,2X,2A4,10X,24HNL2SOL TEST SUMMARY.....,10X,
     1          32H(* = FINITE-DIFFERENCE JACOBIAN)/
     2          48H0 PROBLEM    N   P  NITER   NF   NG  IV1  X0SCAL,5X,
     3          39HFINAL F     PRELDF     NRELDF     RELDX/)
         WRITE(NOUT,60) JTYP(JAC), TITLE1, TITLE2,
     1                (IS(I,NPROB),I=1,5),IRC(NPROB),(RS(I,NPROB),I=1,5)
 60      FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3)
 100     CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF NLTEST FOLLOWS  ***
      END
      SUBROUTINE TESTJ(N, P, X, NFCALL, J, UIPARM, URPARM, UFPARM)      TSJ00010
C
C  ***  PARAMETERS  ***
C
      INTEGER N, P, NFCALL, UIPARM(1)
      REAL X(P), J(N,P), URPARM(1)
      EXTERNAL UFPARM
C
C     ..................................................................
C     ..................................................................
C
C     *****PURPOSE.
C     THIS ROUTINE EVALUATES THE JACOBIAN MATRIX  J  FOR THE VARIOUS
C     TEST PROBLEMS LISTED IN REFERENCES (1), (2), AND (3).
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NN IS THE ROW DIMENSION OF  J  AS DECLARED IN THE CALLING
C             PROGRAM.
C        N IS THE ACTUAL NUMBER OF ROWS IN  J  AND IS THE LENGTH OF  R.
C        P IS THE NUMBER OF PARAMETERS BEING ESTIMATED AND HENCE IS
C             THE LENGTH OF X.
C        X IS THE VECTOR OF PARAMETERS AT WHICH THE JACOBIAN MATRIX  J
C             IS TO BE COMPUTED.
C        NFCALL IS THE INVOCATION COUNT OF  TESTR  AT THE TIME WHEN  R
C             WAS EVALUATED AT  X.  TESTR IGNORES NFCALL.
C        R IS THE RESIDUAL VECTOR AT  X  (AND IS IGNORED).
C        NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING
C             SOLVED.
C        URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED).
C        UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED).
C        TESTR IS THE SUBROUTINE THAT COMPUTES  R  (AND IS IGNORED).
C
C     ON OUTPUT.
C
C        J IS THE JACOBIAN MATRIX AT X.
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS
C     SUCH AS NL2SOL.  IN PARTICULAR, THESE PROBLEMS MAY BE USED TO
C     CHECK WHETHER  NL2SOL  HAS BEEN SUCCESSFULLY TRANSPORTED TO
C     A PARTICULAR MACHINE.
C
C     *****ALGORITHM NOTES.
C     NONE
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C     NONE
C
C     *****REFERENCES
C     (1) GILL, P.E.; & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION
C        OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71.
C
C     (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS
C        OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING,
C        EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER,
C        ACADEMIC PRESS, NEW YORK.
C
C     (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON-
C        LIKE METHOD BASED UPON GAUSSIAN ELIMINATION,
C        SIAM J. NUMER. ANAL. 6, PP. 560-569.
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C  ***  LOCAL VARIABLES AND CONSTANTS  ***
C
      REAL E, EXPMIN, R2, T, THETA, TI, TIM1, TIP1, TPI,
     1   TPIM1, TPIP1, TWOPI, U, UFTOLG, UKOW(11), V, W, Z, ZERO
      INTEGER I, K, NEX, NM1
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      REAL ALOG, AMIN1, COS, EXP, FLOAT, SIN, SQRT
C/
      EXTERNAL RMDCON
      REAL RMDCON
C
C/6
C /6
      DATA TWOPI/6.283185E+0/, ZERO/0.E+0/
C /7
C     PARAMETER (TWOPI=6.283185E+0, ZERO=0.E+0)
C /
C/6
C/7
C     SAVE EXPMIN, UFTOLG
C/
      DATA UKOW(1)/4.0/, UKOW(2)/2.0/, UKOW(3)/1.0/,
     1   UKOW(4)/5.0E-1/, UKOW(5)/2.5E-1/, UKOW(6)/1.67E-1/,
     2   UKOW(7)/1.25E-1/, UKOW(8)/1.0E-1/, UKOW(9)/8.33E-2/,
     3   UKOW(10)/7.14E-2/, UKOW(11)/6.25E-2/
C  ***  MACHINE DEPENDENT CONSTANT  ***
      DATA EXPMIN/0.0/, UFTOLG/0./
C
C
C-----------------------------------------------------------------------
C
      NEX = UIPARM(1)
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100,
     1   1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100,
     2   2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100,
     3   2500, 1300, 1400, 1500, 1600), NEX
C
C  ***  ROSENBROCK  ***
 100  J(1,1) = -2.0E1*X(1)
      J(1,2) = 1.0E1
      J(2,1) = -1.0
      J(2,2) = 0.0
      GO TO 9999
C  ***  HELIX  ***
 200  T = X(1)**2 + X(2)**2
      TI = 1.E2/(TWOPI*T)
      J(1,1) = TI*X(2)
      T = 1.E1/SQRT(T)
      J(2,1) = X(1)*T
      J(3,1) = 0.
      J(1,2) = -TI*X(1)
      J(2,2) = X(2)*T
      J(3,2) = 0.
      J(1,3) = 1.E1
      J(2,3) = 0.
      J(3,3) = 1.
      GO TO 9999
C  ***  SINGULAR  ***
 300  DO 301 K = 1,4
         DO 301 I = 1,4
 301          J(I,K) = 0.
      J(1,1) = 1.
      J(1,2) = 1.E1
      J(2,3) = SQRT(5.)
      J(2,4) = -J(2,3)
      J(3,2) = 2.*(X(2) - 2.*X(3))
      J(3,3) = -2.*J(3,2)
      J(4,1) = SQRT(4.E1)*(X(1) - X(4))
      J(4,4) = -J(4,1)
      GO TO 9999
C  ***  WOODS  ***
 400  DO 401 K = 1,4
         DO 401 I = 1,7
 401            J(I,K) = 0.
      J(1,1) = -2.E1*X(1)
      J(1,2) = 1.E1
      J(2,1) = -1.
      J(3,4) = SQRT(9.E1)
      J(3,3) = -2.*X(3)*J(3,4)
      J(4,3) = -1.
      J(5,2) = SQRT(9.9)
      J(5,4) = J(5,2)
      J(6,2) = SQRT(0.2)
      J(7,4) = J(6,2)
      GO TO 9999
C  ***  ZANGWILL  ***
 500  DO 501 K = 1,3
         DO 501 I = 1,3
 501            J(I,K) = 1.
      J(1,2) = -1.
      J(2,1) = -1.
      J(3,3) = -1.
      GO TO 9999
C  ***  ENGVALL  ***
 600  J(1,1) = 2.*X(1)
      J(1,2) = 2.*X(2)
      J(1,3) = 2.*X(3)
      J(2,1) = J(1,1)
      J(2,2) = J(1,2)
      J(2,3) = 2.*(X(3) - 2.)
      J(3,1) = 1.
      J(3,2) = 1.
      J(3,3) = 1.
      J(4,1) = 1.
      J(4,2) = 1.
      J(4,3) = -1.
      T = 2.*(5.*X(3) - X(1) + 1.)
      J(5,1) = 3.*X(1)**2 - T
      J(5,2) = 6.*X(2)
      J(5,3) = 5.*T
      GO TO 9999
C  ***  BRANIN  ***
 700  J(1,1) = 4.
      J(1,2) = 4.
      J(2,1) = 3. + (X(1) - 2.)*(3.*X(1) - 2.*X(2) - 2.) +
     1   X(2)*X(2)
      J(2,2) = 1. + 2.*(2.*X(1) - X(2)*X(2)) - (X(1) - X(2))**2
      GO TO 9999
C  ***  BEALE  ***
 800  J(1,1) = X(2) - 1.
      J(1,2) = X(1)
      J(2,1) = X(2)**2 - 1.
      J(2,2) = 2.*X(1)*X(2)
      J(3,1) = X(2)**3 - 1.
      J(3,2) = 3.*X(1)*(X(2)**2)
      GO TO 9999
C  ***  CRAGG & LEVY  ***
 900  DO 901 I = 1,5
         DO 901 K = 1,4
 901          J(I,K) = 0.
      T = EXP(X(1))
      J(1,2) = -2.*(T - X(2))
      J(1,1) = -T * J(1,2)
      J(2,2) = 3.0E1*(X(2) - X(3))**2
      J(2,3) = -J(2,2)
      J(3,3) = 2.*SIN(X(3) - X(4))/(COS(X(3) - X(4)))**3
      J(3,4) = -J(3,3)
      J(4,1) = 4.*X(1)**3
      J(5,4) = 1.
      GO TO 9999
C  ***  BOX  ***
 1000 IF (EXPMIN .EQ. ZERO) EXPMIN = 1.999*ALOG(RMDCON(2))
      DO 1001 I = 1,10
         TI = -0.1*FLOAT(I)
         E = ZERO
         T = X(1)*TI
         IF (T .GE. EXPMIN) E = EXP(T)
         J(I,1) = TI*E
         E = ZERO
         T = X(2)*TI
         IF (T .GE. EXPMIN) E = EXP(T)
         J(I,2) = -TI*E
         J(I,3) = EXP(1.E1*TI) - EXP(TI)
 1001    CONTINUE
      GO TO 9999
C  ***  DAVIDON 1  ***
 1100 NM1 = N-1
      DO 1101 I = 1,NM1
         TI = FLOAT(I)
         T = 1.
         DO 1101 K = 1,P
              J(I,K) = T
              T = T*TI
 1101         CONTINUE
      J(N,1) = 1.
      DO 1102 K = 2,P
 1102    J(N,K) = 0.
      GO TO 9999
C  ***  FREUDENSTEIN & ROTH  ***
 1200 J(1,1) = 1.
      J(1,2) = -2. + X(2)*(1.E1 - 3.*X(2))
      J(2,1) = 1.
      J(2,2) = -1.4E1 + X(2)*(2. + 3.*X(2))
      GO TO 9999
C  ***  WATSON  ***
 1300 CONTINUE
 1400 CONTINUE
 1500 CONTINUE
 1600 DO 1603 I = 1,29
         TI = FLOAT(I)/2.9E1
         R2 = X(1)
         T= 1.
         DO 1601 K = 2,P
              T = T*TI
              R2 = R2 + T*X(K)
 1601    CONTINUE
         R2 = -2.*R2
         J(I,1) = R2
         T = 1.
         R2 = TI*R2
         DO 1602 K = 2,P
              J(I,K) = T*(FLOAT(K-1) + R2)
              T = T*TI
 1602    CONTINUE
 1603 CONTINUE
      DO 1604 I = 30,31
         DO 1604 K = 2,P
 1604         J(I,K) = 0.
      J(30,1) = 1.
      J(31,1) = -2.*X(1)
      J(31,2) = 1.
      GO TO 9999
C  ***  CHEBYQUAD  ***
 1700 DO 1701 K = 1,N
         TIM1 = -1./FLOAT(N)
         Z = 2.*X(K) - 1.
         TI = Z*TIM1
         TPIM1 = 0.
         TPI = 2.*TIM1
         Z = Z + Z
         DO 1701 I = 1,N
              J(I,K) = TPI
              TPIP1 = 4.*TI + Z*TPI - TPIM1
              TPIM1 = TPI
              TPI = TPIP1
              TIP1 = Z*TI - TIM1
              TIM1 = TI
              TI = TIP1
 1701         CONTINUE
      GO TO 9999
C  ***  BROWN AND DENNIS  ***
 1800 DO 1801 I = 1, N
         TI = 0.2*FLOAT(I)
         J(I,1) = 2.0*(X(1) + X(2)*TI - EXP(TI))
         J(I,2) = TI*J(I,1)
         T = SIN(TI)
         J(I,3) = 2.0*(X(3) + X(4)*T - COS(TI))
         J(I,4) = T*J(I,3)
 1801    CONTINUE
      GO TO 9999
C  ***  BARD  ***
 1900 DO 1901 I = 1,15
         J(I,1) = -1.
         U = FLOAT(I)
         V = 1.6E1 - U
         W = AMIN1 (U,V)
         T = U/(X(2)*V + X(3)*W)**2
         J(I,2) = V*T
         J(I,3) = W*T
 1901 CONTINUE
      GO TO 9999
C  *** JENNRICH & SAMPSON  ***
 2000 DO 2001 I = 1,10
         TI = FLOAT(I)
         J(I,1) = -TI*EXP(TI*X(1))
         J(I,2) = -TI*EXP(TI*X(2))
 2001    CONTINUE
      GO TO 9999
C  ***  KOWALIK & OSBORNE  ***
 2100 DO 2101 I = 1,11
         T = -1./(UKOW(I)**2 + X(3)*UKOW(I) + X(4))
         J(I,1) = T*(UKOW(I)**2 + X(2)*UKOW(I))
         J(I,2) = X(1)*UKOW(I)*T
         T = T*J(I,1)*X(1)
         J(I,3) = UKOW(I)*T
         J(I,4) = T
 2101 CONTINUE
      GO TO 9999
C  ***  OSBORNE 1  ***
 2200 DO 2201 I = 1,33
         TI = 1.0E1*FLOAT(1-I)
         J(I,1) = -1.
         J(I,2) = -EXP(X(4)*TI)
         J(I,3) = -EXP(X(5)*TI)
         J(I,4) = TI*X(2)*J(I,2)
         J(I,5) = TI*X(3)*J(I,3)
 2201    CONTINUE
      GO TO 9999
C  ***  OSBORNE 2  ***
C     ***  UFTOLG IS A MACHINE-DEPENDENT CONSTANT.  IT IS JUST SLIGHTLY
C     ***  LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER.
 2300 IF (UFTOLG .EQ. 0.) UFTOLG = 1.999 * ALOG(RMDCON(2))
      DO 2302 I = 1,65
         TI = FLOAT(1 - I)*1.E-1
         J(I,1) = -EXP(X(5)*TI)
         J(I,5) = X(1)*TI*J(I,1)
         DO 2301 K = 2,4
              T = X(K + 7) + TI
              R2 = 0.
              THETA = -X(K+4)*T*T
              IF (THETA .GT. UFTOLG) R2 = -EXP(THETA)
              J(I,K) = R2
              R2 = -T*R2*X(K)
              J(I,K+4) = R2*T
              J(I,K+7) = 2.*X(K+4)*R2
 2301         CONTINUE
 2302    CONTINUE
      GO TO 9999
C  ***  MADSEN  ***
 2400 J(1,1) = 2.*X(1) + X(2)
      J(1,2) = 2.*X(2) + X(1)
      J(2,1) = COS(X(1))
      J(2,2) = 0.
      J(3,1) = 0.
      J(3,2) = -SIN(X(2))
      GO TO 9999
C  ***  MEYER  ***
 2500 DO 2501 I = 1, 16
         TI = FLOAT(5*I + 45)
         U = TI + X(3)
         T = EXP(X(2)/U)
         J(I,1) = T
         J(I,2) = X(1)*T/U
         J(I,3) = -X(1)*X(2)*T/(U*U)
 2501    CONTINUE
      GO TO 9999
C  ***  BROWN  ***
 2600 CONTINUE
 2700 CONTINUE
 2800 CONTINUE
 2900 NM1 = N - 1
      DO 2901 K = 1, N
         DO 2901 I = 1, NM1
              J(I,K) = 1.0
              IF (I .EQ. K) J(I,K) = 2.0
 2901         CONTINUE
      DO 2903 K = 1, N
         T = 1.0
         DO 2902 I = 1,N
              IF (I .NE. K) T = T*X(I)
 2902         CONTINUE
         J(N,K) = T
 2903    CONTINUE
      GO TO 9999
C
C
 9999 RETURN
      END
      SUBROUTINE TESTR(N, P, X, NFCALL, R, UIPARM, URPARM, UFPARM)      TES00010
C
C     *****PARAMETERS.
C
      INTEGER N, P, NFCALL, UIPARM(1)
      REAL X(P), R(N), URPARM(1)
      EXTERNAL UFPARM
C
C     ..................................................................
C     ..................................................................
C
C     *****PURPOSE.
C     THIS ROUTINE EVALUATES  R  FOR THE VARIOUS TEST FUNCTIONS IN
C        REFERENCES (1), (2), AND (3), AS WELL AS FOR SOME VARIATIONS
C        SUGGESTED BY JORGE MORE (PRIVATE COMMUNICATION) ON SOME OF
C        THESE TEST PROBLEMS (FOR NEX .GE. 30).
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        N IS THE LENGTH OF R.
C        P IS THE LENGTH OF X.
C        X IS THE POINT AT WHICH THE RESIDUAL VECTOR R IS TO BE
C             COMPUTED.
C        NFCALL IS THE INVOCATION COUNT OF TESTR.
C        NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING
C             SOLVED.
C        URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED).
C        UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED).
C
C     ON OUTPUT.
C
C        R IS THE RESIDUAL VECTOR AT X.
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS
C     SUCH AS NL2SOL.  IN PARTICULAR, THESE PROBLEMS MAY BE USED TO
C     CHECK WHETHER  NL2SOL  HAS BEEN SUCCESSFULLY TRANSPORTED TO
C     A PARTICULAR MACHINE.
C
C     *****ALGORITHM NOTES.
C     NONE
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C     NONE
C
C     *****REFERENCES
C     (1) GILL, P.E.. & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION
C        OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71.
C
C     (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS
C        OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING,
C        EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER,
C        ACADEMIC PRESS, NEW YORK.
C
C     (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON-
C        LIKE METHOD BASED UPON GAUSSIAN ELIMINATION,
C        SIAM J. NUMER. ANAL. 6, PP. 560-569.
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C  ***  LOCAL VARIABLES AND CONSTANTS  ***
C
      REAL E1, E2, FLOATN, RI, R1, R2, T, THETA, TI, TIM1,
     1             TIP1, TWOPI, T1, T2, U, V, W, Z
      REAL YBARD(15), YKOW(11), UKOW(11), YOSB1(33),
     1             YOSB2(65), YMEYER(16)
      INTEGER I, J, NEX, NM1
      REAL EXPMAX, EXPMIN, UFTOLG
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER MOD
      REAL ALOG, AMIN1, ATAN2, COS, EXP, FLOAT, SIN, SQRT
C/
      EXTERNAL RMDCON
      REAL RMDCON
C /6
      DATA TWOPI/6.283185E+0/
C /7
C     PARAMETER (TWOPI=6.283185E+0)
C /
C/6
C/7
C     SAVE EXPMAX, EXPMIN, UFTOLG
C/
      DATA YBARD(1)/1.4E-1/, YBARD(2)/1.8E-1/, YBARD(3)/2.2E-1/,
     1   YBARD(4)/2.5E-1/, YBARD(5)/2.9E-1/, YBARD(6)/3.2E-1/,
     2   YBARD(7)/3.5E-1/, YBARD(8)/3.9E-1/, YBARD(9)/3.7E-1/,
     3   YBARD(10)/5.8E-1/, YBARD(11)/7.3E-1/, YBARD(12)/9.6E-1/,
     4   YBARD(13)/1.34/, YBARD(14)/2.10/, YBARD(15)/4.39/
      DATA YKOW(1)/1.957E-1/, YKOW(2)/1.947E-1/, YKOW(3)/1.735E-1/,
     1   YKOW(4)/1.600E-1/, YKOW(5)/8.44E-2/, YKOW(6)/6.27E-2/,
     2   YKOW(7)/4.56E-2/, YKOW(8)/3.42E-2/, YKOW(9)/3.23E-2/,
     3   YKOW(10)/2.35E-2/, YKOW(11)/2.46E-2/
      DATA UKOW(1)/4.0/, UKOW(2)/2.0/, UKOW(3)/1.0/,
     1   UKOW(4)/5.0E-1/, UKOW(5)/2.5E-1/, UKOW(6)/1.67E-1/,
     2   UKOW(7)/1.25E-1/, UKOW(8)/1.0E-1/, UKOW(9)/8.33E-2/,
     3   UKOW(10)/7.14E-2/, UKOW(11)/6.25E-2/
      DATA YOSB1(1)/8.44E-1/, YOSB1(2)/9.08E-1/, YOSB1(3)/9.32E-1/,
     1   YOSB1(4)/9.36E-1/, YOSB1(5)/9.25E-1/, YOSB1(6)/9.08E-1/,
     2   YOSB1(7)/8.81E-1/, YOSB1(8)/8.50E-1/, YOSB1(9)/8.18E-1/,
     3   YOSB1(10)/7.84E-1/, YOSB1(11)/7.51E-1/, YOSB1(12)/7.18E-1/,
     4   YOSB1(13)/6.85E-1/, YOSB1(14)/6.58E-1/, YOSB1(15)/6.28E-1/,
     5   YOSB1(16)/6.03E-1/, YOSB1(17)/5.80E-1/, YOSB1(18)/5.58E-1/,
     6   YOSB1(19)/5.38E-1/, YOSB1(20)/5.22E-1/, YOSB1(21)/5.06E-1/,
     7   YOSB1(22)/4.90E-1/, YOSB1(23)/4.78E-1/, YOSB1(24)/4.67E-1/,
     8   YOSB1(25)/4.57E-1/, YOSB1(26)/4.48E-1/, YOSB1(27)/4.38E-1/,
     9   YOSB1(28)/4.31E-1/, YOSB1(29)/4.24E-1/, YOSB1(30)/4.20E-1/,
     A   YOSB1(31)/4.14E-1/, YOSB1(32)/4.11E-1/, YOSB1(33)/4.06E-1/
      DATA YOSB2(1)/1.366/, YOSB2(2)/1.191/, YOSB2(3)/1.112/,
     1   YOSB2(4)/1.013/, YOSB2(5)/9.91E-1/, YOSB2(6)/8.85E-1/,
     2   YOSB2(7)/8.31E-1/, YOSB2(8)/8.47E-1/, YOSB2(9)/7.86E-1/,
     3   YOSB2(10)/7.25E-1/, YOSB2(11)/7.46E-1/, YOSB2(12)/6.79E-1/,
     4   YOSB2(13)/6.08E-1/, YOSB2(14)/6.55E-1/, YOSB2(15)/6.16E-1/,
     5   YOSB2(16)/6.06E-1/, YOSB2(17)/6.02E-1/, YOSB2(18)/6.26E-1/,
     6   YOSB2(19)/6.51E-1/, YOSB2(20)/7.24E-1/, YOSB2(21)/6.49E-1/,
     7   YOSB2(22)/6.49E-1/, YOSB2(23)/6.94E-1/, YOSB2(24)/6.44E-1/,
     8   YOSB2(25)/6.24E-1/, YOSB2(26)/6.61E-1/, YOSB2(27)/6.12E-1/,
     9   YOSB2(28)/5.58E-1/, YOSB2(29)/5.33E-1/, YOSB2(30)/4.95E-1/,
     A   YOSB2(31)/5.00E-1/, YOSB2(32)/4.23E-1/, YOSB2(33)/3.95E-1/,
     B   YOSB2(34)/3.75E-1/, YOSB2(35)/3.72E-1/, YOSB2(36)/3.91E-1/,
     C   YOSB2(37)/3.96E-1/, YOSB2(38)/4.05E-1/, YOSB2(39)/4.28E-1/,
     D   YOSB2(40)/4.29E-1/, YOSB2(41)/5.23E-1/, YOSB2(42)/5.62E-1/,
     E   YOSB2(43)/6.07E-1/, YOSB2(44)/6.53E-1/, YOSB2(45)/6.72E-1/,
     F   YOSB2(46)/7.08E-1/, YOSB2(47)/6.33E-1/, YOSB2(48)/6.68E-1/,
     G   YOSB2(49)/6.45E-1/, YOSB2(50)/6.32E-1/, YOSB2(51)/5.91E-1/,
     H   YOSB2(52)/5.59E-1/, YOSB2(53)/5.97E-1/, YOSB2(54)/6.25E-1/,
     I   YOSB2(55)/7.39E-1/, YOSB2(56)/7.10E-1/, YOSB2(57)/7.29E-1/,
     J   YOSB2(58)/7.20E-1/, YOSB2(59)/6.36E-1/, YOSB2(60)/5.81E-1/
      DATA YOSB2(61)/4.28E-1/, YOSB2(62)/2.92E-1/, YOSB2(63)/1.62E-1/,
     1   YOSB2(64)/9.8E-2/, YOSB2(65)/5.4E-2/
      DATA YMEYER(1)/3.478E4/, YMEYER(2)/2.861E4/, YMEYER(3)/2.365E4/,
     1   YMEYER(4)/1.963E4/, YMEYER(5)/1.637E4/, YMEYER(6)/1.372E4/,
     2   YMEYER(7)/1.154E4/, YMEYER(8)/9.744E3/, YMEYER(9)/8.261E3/,
     3   YMEYER(10)/7.030E3/, YMEYER(11)/6.005E3/, YMEYER(12)/5.147E3/,
     4   YMEYER(13)/4.427E3/, YMEYER(14)/3.820E3/, YMEYER(15)/3.307E3/,
     5   YMEYER(16)/2.872E3/
C
      DATA EXPMAX/0./, UFTOLG/0./
C
C
C-----------------------------------------------------------------------
C
      NEX = UIPARM(1)
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100,
     1   1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100,
     2   2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100,
     3   2500, 1300, 1400, 1500, 1600), NEX
C
C  ***  ROSENBROCK   ***
 100  R(1) = 1.0E1*(X(2) - X(1)**2)
      R(2) = 1.0 - X(1)
      GO TO 9999
C  ***  HELIX   ***
 200  THETA = ATAN2(X(2), X(1))/TWOPI
      IF (X(1) .LE. 0. .AND. X(2) .LE. 0.) THETA = THETA + 1.
      R(1) = 1.0E1*(X(3) - 1.0E1*THETA)
      R(2) = 1.0E1*(SQRT(X(1)**2 + X(2)**2) - 1.0)
      R(3) = X(3)
      GO TO 9999
C  ***  SINGULAR   ***
 300  R(1) = X(1) + 1.0E1*X(2)
      R(2) = SQRT(5.0)*(X(3) - X(4))
      R(3) = (X(2) - 2.0*X(3))**2
      R(4) = SQRT(1.0E1)*(X(1) - X(4))**2
      GO TO 9999
C  ***  WOODS   ***
 400  R(1) = 1.0E1*(X(2) - X(1)**2)
      R(2) = 1.0 - X(1)
      R(3) = SQRT(9.0E1)*(X(4) - X(3)**2)
      R(4) = 1.0 - X(3)
      R(5) = SQRT(9.9)*(X(2) + X(4) - 2.)
      T = SQRT(2.0E-1)
      R(6) = T*(X(2) - 1.0)
      R(7) = T*(X(4) - 1.0)
      GO TO 9999
C  ***  ZANGWILL
 500  R(1) = X(1) - X(2) + X(3)
      R(2) = -X(1) + X(2) + X(3)
      R(3) = X(1) + X(2) - X(3)
      GO TO 9999
C  ***  ENGVALL   ***
 600  R(1) = X(1)**2 + X(2)**2 + X(3)**2 - 1.0
      R(2) = X(1)**2 + X(2)**2 + (X(3) - 2.0)**2 - 1.0
      R(3) = X(1) + X(2) + X(3) - 1.0
      R(4) = X(1) + X(2) - X(3) + 1.0
      R(5) = X(1)**3 + 3.0*X(2)**2 + (5.0*X(3) - X(1) + 1.0)**2
     1               - 3.6E1
      GO TO 9999
C  ***  BRANIN ***
 700  R(1) = 4.0*(X(1) + X(2))
      R(2) = R(1) + (X(1) - X(2))*((X(1) - 2.0)**2 +
     1       X(2)**2 - 1.0)
      GO TO 9999
C  ***  BEALE  ***
 800  R(1) = 1.5 - X(1)*(1.0 - X(2))
      R(2) = 2.25 - X(1)*(1.0 - X(2)**2)
      R(3) = 2.625 - X(1)*(1.0 -  X(2)**3)
      GO TO 9999
C  ***  CRAGG AND LEVY  ***
 900  R(1) = (EXP(X(1)) - X(2))**2
      R(2) = 1.0E1*(X(2) - X(3))**3
      R(3) = ( SIN(X(3) - X(4)) / COS(X(3) - X(4)) )**2
      R(4) = X(1)**4
      R(5) = X(4) - 1.0
      GO TO 9999
C  ***  BOX  ***
 1000 IF (EXPMAX .GT. 0.) GO TO 1001
         EXPMAX = 1.999 * ALOG(RMDCON(5))
         EXPMIN = 1.999 * ALOG(RMDCON(2))
 1001 IF (-EXPMAX .GE. AMIN1(X(1), X(2), X(3))) GO TO 1003
      DO 1002 I = 1,10
         TI = -0.1*FLOAT(I)
         T1 = TI*X(1)
         E1 = 0.
         IF (T1 .GT. EXPMIN) E1 = EXP(T1)
         T2 = TI*X(2)
         E2 = 0.
         IF (T2 .GT. EXPMIN) E2 = EXP(T2)
         R(I) = (E1 - E2) - X(3)*(EXP(TI) - EXP(1.0E1*TI))
 1002 CONTINUE
      GO TO 9999
 1003 NFCALL = -1
      GO TO 9999
C  ***  DAVIDON 1  ***
 1100 NM1 = N - 1
      DO 1102 I = 1, NM1
         R1 = 0.0
         TI = FLOAT(I)
         T = 1.
         DO 1101 J = 1,P
              R1 = R1 + T*X(J)
              T = T*TI
 1101         CONTINUE
         R(I) = R1
 1102    CONTINUE
      R(N) = X(1) - 1.0
      GO TO 9999
C  ***  FREUDENSTEIN AND ROTH  ***
 1200 R(1) = -1.3E1 + X(1) - 2.0*X(2) + 5.0*X(2)**2 - X(2)**3
      R(2) = -2.9E1 + X(1) - 1.4E1*X(2) + X(2)**2 + X(2)**3
      GO TO 9999
C  ***  WATSON  ***
 1300  CONTINUE
 1400  CONTINUE
 1500  CONTINUE
 1600 DO 1602 I = 1, 29
         TI = FLOAT(I)/2.9E1
         R1 = 0.0
         R2 = X(1)
         T = 1.0
         DO 1601 J = 2, P
              R1 = R1 + FLOAT(J-1)*T*X(J)
              T = T*TI
              R2 = R2 + T*X(J)
 1601         CONTINUE
         R(I) = R1 - R2*R2 - 1.0
         IF (NEX .GE. 33 .AND. NEX .LE. 36) R(I) = R(I) + 10.
 1602    CONTINUE
      R(30) = X(1)
      R(31) = X(2) - X(1)**2 - 1.0
      IF (NEX .LT. 33 .OR. NEX .GT. 36) GO TO 9999
      R(30) = R(30) + 10.
      R(31) = R(31) + 10.
      GO TO 9999
C  ***  CHEBYQUAD  ***
 1700 DO 1701 I = 1,N
 1701    R(I) = 0.0
      DO 1702 J = 1,N
         TIM1 = 1.0
         TI = 2.0*X(J) - 1.0
         Z = TI + TI
         DO 1702 I = 1,N
              R(I) = R(I) + TI
              TIP1 = Z*TI -TIM1
              TIM1 = TI
              TI = TIP1
 1702         CONTINUE
      FLOATN = FLOAT(N)
      DO 1703 I = 1,N
         TI = 0.0
         IF (MOD(I,2) .EQ. 0) TI = -1.0/FLOAT(I*I - 1)
         R(I) = TI - R(I)/FLOATN
 1703    CONTINUE
      GO TO 9999
C  ***  BROWN AND DENNIS  ***
 1800  DO 1801 I = 1, N
         TI = 0.2*FLOAT(I)
         R(I) = (X(1) + X(2)*TI - EXP(TI))**2 +
     1             (X(3) + X(4)*SIN(TI) - COS(TI))**2
 1801    CONTINUE
      GO TO 9999
C  ***  BARD  ***
 1900 DO 1901 I = 1, 15
         U = FLOAT(I)
         V = 1.6E1 - U
         W = AMIN1(U,V)
         R(I) = YBARD(I) - (X(1) + U/(X(2)*V + X(3)*W))
         IF (NEX .EQ. 30) R(I) = R(I) + 10.
 1901    CONTINUE
      GO TO 9999
C  ***  JENNRICH AND SAMPSON  ***
 2000 DO 2001 I = 1, 10
         TI = FLOAT(I)
         R(I) = 2.0 + 2.0*TI - (EXP(TI*X(1)) +
     1          EXP(TI*X(2)))
 2001    CONTINUE
      GO TO 9999
C  ***  KOWALIK AND OSBORNE  ***
 2100 DO 2101 I = 1, 11
         R(I) = YKOW(I) - X(1)*(UKOW(I)**2 + X(2)*UKOW(I))/(UKOW(I)**2 +
     1          X(3)*UKOW(I) + X(4))
         IF (NEX .EQ. 31) R(I) = R(I) + 10.
 2101    CONTINUE
      GO TO 9999
C  ***  OSBORNE 1  ***
 2200 DO 2201 I = 1, 33
         TI = 1.0E1*FLOAT(1-I)
         R(I) = YOSB1(I) - (X(1) + X(2)*EXP(X(4)*TI) +
     1          X(3)*EXP(X(5)*TI))
 2201    CONTINUE
      GO TO 9999
C  ***  OSBORNE 2  ***
C     ***  UFTOLG IS A MACHINE-DEPENDENT CONSTANT.  IT IS JUST SLIGHTLY
C     ***  LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER.
 2300 IF (UFTOLG .EQ. 0.) UFTOLG = 1.999 * ALOG(RMDCON(2))
      DO 2302 I = 1, 65
         TI = 0.1*FLOAT(1-I)
         RI = X(1)*EXP(X(5)*TI)
         DO 2301 J = 2, 4
              T = 0.
              THETA = -X(J+4) * (TI + X(J+7))**2
              IF (THETA .GT. UFTOLG) T = EXP(THETA)
              RI = RI + X(J)*T
 2301         CONTINUE
         R(I) = YOSB2(I) - RI
 2302 CONTINUE
      GO TO 9999
C  ***  MADSEN  ***
 2400 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2)
      R(2) = SIN(X(1))
      R(3) = COS(X(2))
      GO TO 9999
C  ***  MEYER  ***
 2500 DO 2501 I = 1, 16
         TI = FLOAT(5*I + 45)
         R(I)=X(1)*EXP(X(2)/(TI + X(3))) - YMEYER(I)
         IF (NEX .EQ. 32) R(I) = R(I) + 10.
 2501    CONTINUE
      GO TO 9999
C  ***  BROWN  ***
 2600 CONTINUE
 2700 CONTINUE
 2800 CONTINUE
 2900 T = X(1) - FLOAT(N + 1)
      DO 2901 I = 2, N
 2901    T = T + X(I)
      NM1 = N - 1
      DO 2902 I = 1, NM1
 2902    R(I) = T + X(I)
      T = X(1)
      DO 2903 I = 2, N
 2903    T = T * X(I)
      R(N) = T - 1.0
      GO TO 9999
C
 9999 RETURN
C     ..... LAST CARD OF TESTR .........................................
      END
      SUBROUTINE TODAY(DATIME)                                          TOD00010
C
C  ***  SUPPLY SUMSOL VERSION  ***
C
C/6
      REAL DATIME(4), DT1, DT2, DT3, DT4
      DATA DT1,DT2,DT3,DT4/4HNL2S,4HOL  ,4HVER.,4H2.2 /
C/7
C     CHARACTER*4 DATIME(4), DT1, DT2, DT3, DT4
C     DATA DT1,DT2,DT3,DT4/'NL2S','OL  ','VER.','2.2 '/
C/
C
      DATIME(1) = DT1
      DATIME(2) = DT2
      DATIME(3) = DT3
      DATIME(4) = DT4
 999  RETURN
C  ***  LAST LINE OF DATIME FOLLOWS  ***
      END
      SUBROUTINE XINIT(P, X, NEX)                                       XIN00010
C
C     *****PARAMETERS...
C
      INTEGER NEX, P
      REAL X(P)
C
C     ..................................................................
C
C     *****PURPOSE...
C     THIS ROUTINE INITIALIZES THE SOLUTION VECTOR X ACCORDING TO
C     THE INITIAL VALUES FOR THE VARIOUS TEST FUNCTIONS GIVEN IN
C     REFERENCES (1), (2), AND (3).
C     SUBROUTINES TESTR AND TESTJ.  (SEE TESTR FOR REFERENCES.)
C
C     *****PARAMETER DESCRIPTION...
C     ON INPUT...
C
C        NEX IS THE TEST PROBLEM NUMBER.
C
C        P IS THE NUMBER OF PARAMETERS.
C
C     ON OUTPUT...
C
C        X IS THE INITIAL GUESS TO THE SOLUTION.
C
C     *****APPLICATION AND USAGE RESTRICTIONS...
C     THIS ROUTINE IS CALLED BY NLTEST.
C
C     ..................................................................
C
C     *****LOCAL VARIABLES...
      INTEGER I
      REAL PP1INV
C     *****INTRINSIC FUNCTIONS...
C/+
      REAL FLOAT
C/
C
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100,
     1   1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100,
     2   2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100,
     3   2500, 1300, 1400, 1500, 1600),NEX
C
C  ***  ROSENBROCK  ***
 100  X(1) = -1.2
      X(2) = 1.0
      GO TO 9999
C  ***  HELIX  ***
 200  X(1) = -1.0
      X(2) = 0.0
      X(3) = 0.0
      GO TO 9999
C  *** SINGULAR  ***
 300  X(1) = 3.0
      X(2) = -1.0
      X(3) = 0.0
      X(4) = 1.0
      GO TO 9999
C  ***  WOODS  ***
 400  X(1) = -3.0
      X(2) = -1.0
      X(3) = -3.0
      X(4) = -1.0
      GO TO 9999
C  ***  ZANGWILL  ***
 500  X(1) = 1.0E2
      X(2) = -1.0
      X(3) = 2.5
      GO TO 9999
C  ***  ENGVALL  ***
 600  X(1) = 1.0
      X(2) = 2.0
      X(3) = 0.0
      GO TO 9999
C  *** BRANIN  ***
 700  X(1) = 2.0
      X(2) = 0.0
      GO TO 9999
C  ***  BEALE  ***
 800  X(1) = 1.0E-1
      X(2) = 1.0E-1
      GO TO 9999
C  *** CRAGG AND LEVY  ***
 900  X(1) = 1.0
      X(2) = 2.0
      X(3) = 2.0
      X(4) = 2.0
      GO TO 9999
C  ***  BOX  ***
 1000 X(1) = 0.0
      X(2) = 1.0E1
      X(3) = 2.0E1
      GO TO 9999
C  ***  DAVIDON 1  ***
 1100 DO 1101 I = 1,P
 1101    X(I) = 0.0
      GO TO 9999
C  ***  FREUDENSTEIN AND ROTH  ***
 1200 X(1) = 1.5E1
      X(2) = -2.0
      GO TO 9999
C  ***  WATSON  ***
 1300 CONTINUE
 1400 CONTINUE
 1500 CONTINUE
 1600 DO 1601 I = 1,P
 1601    X(I) = 0.0
      GO TO 9999
C  ***  CHEBYQUAD  ***
 1700 PP1INV = 1.0/FLOAT(P + 1)
      DO 1701 I = 1, P
 1701    X(I) = FLOAT(I)*PP1INV
      GO TO 9999
C  *** BROWN AND DENNIS  ***
 1800 X(1) = 2.5E1
      X(2) = 5.0
      X(3) = -5.0
      X(4) = -1.0
      GO TO 9999
C  ***  BARD  ***
 1900 X(1) = 1.
      X(2) = 1.
      X(3) = 1.
      GO TO 9999
C  ***  JENNRICH AND SAMPSON  ***
 2000 X(1) = 3.0E-1
      X(2) = 4.0E-1
      GO TO 9999
C  ***  KOWALIK AND OSBORNE  ***
 2100 X(1) = 2.5E-1
      X(2) = 3.9E-1
      X(3) = 4.15E-1
      X(4) = 3.9E-1
      GO TO 9999
C  ***  OSBORNE 1  ***
 2200 X(1) = 5.0E-1
      X(2) = 1.5
      X(3) = -1.0
      X(4) = 1.0E-2
      X(5) = 2.0E-2
      GO TO 9999
C  ***  OSBORNE 2  ***
 2300 X(1) = 1.3
      X(2) = 6.5E-1
      X(3) = 6.5E-1
      X(4) = 7.0E-1
      X(5) = 6.0E-1
      X(6) = 3.0
      X(7) = 5.0
      X(8) = 7.0
      X(9) = 2.0
      X(10) = 4.5
      X(11) = 5.5
      GO TO 9999
C  ***  MADSEN  ***
 2400 X(1) = 3.0
      X(2) = 1.0
      GO TO 9999
C  ***  MEYER  **
 2500 X(1) = 2.0E-2
      X(2) = 4.0E3
      X(3) = 2.5E2
      GO TO 9999
C  ***  BROWN  ***
 2600 CONTINUE
 2700 CONTINUE
 2800 CONTINUE
 2900 DO 2901 I = 1, P
 2901    X(I) = 5.E-1
      GO TO 9999
C
C
 9999 RETURN
      END
C///////////////////////////////////////////////////////////////////////
C     ***  TEST NL2SOL AND NL2SNO ON MADSEN EXAMPLE  ***                MAD00010
      INTEGER IV(62), UIPARM(1)
      DOUBLE PRECISION V(147), X(2), URPARM(1)
      EXTERNAL MADR, MADJ
      X(1) = 3.0D0
      X(2) = 1.0D0
      IV(1) = 0
      CALL NL2SOL(3, 2, X, MADR, MADJ, IV, V, UIPARM, URPARM, MADR)
      IV(1) = 12
      X(1) = 3.0D0
      X(2) = 1.0D0
      CALL NL2SNO(3, 2, X, MADR, IV, V, UIPARM, URPARM, MADR)
      STOP
      END
      SUBROUTINE MADR(N, P, X, NF, R, UIPARM, URPARM, UFPARM)
      INTEGER N, P, NF, UIPARM(1)
      DOUBLE PRECISION X(P), R(N), URPARM(1)
      EXTERNAL UFPARM
      R(1) = X(1)**2 + X(2)**2 + X(1)*X(2)
      R(2) = DSIN(X(1))
      R(3) = DCOS(X(2))
      RETURN
      END
      SUBROUTINE MADJ(N, P, X, NF, J, UIPARM, URPARM, UFPARM)
      INTEGER N, P, NF, UIPARM(1)
      DOUBLE PRECISION X(P), J(N,P), URPARM(1)
      EXTERNAL UFPARM
      J(1,1) = 2.0D0*X(1) + X(2)
      J(1,2) = 2.0D0*X(2) + X(1)
      J(2,1) = DCOS(X(1))
      J(2,2) = 0.0D0
      J(3,1) = 0.0D0
      J(3,2) = -DSIN(X(2))
      RETURN
      END
C///////////////////////////////////////////////////////////////////////
      INTEGER FUNCTION IMDCON(K)                                        IMD00010
C
      INTEGER K
C
C  ***  RETURN INTEGER MACHINE-DEPENDENT CONSTANTS  ***
C
C     ***  K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER.   ***
C     ***  K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER.  ***
C     ***  K = 3 MEANS RETURN  INPUT UNIT NUMBER.            ***
C          (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.)
C
      INTEGER MDCON(3)
      DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/
C
      IMDCON = MDCON(K)
      RETURN
C  ***  LAST CARD OF IMDCON FOLLOWS  ***
      END
      DOUBLE PRECISION FUNCTION RMDCON(K)                               RMD00010
C
C  ***  RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL  ***
C
C +++  COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES.  +++
C +++  TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE   +++
C +++  DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++
C +++  AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S)  +++
C +++  THAT CORRESPOND TO THE NEW MACHINE.                           +++
C
      INTEGER K
C
C  ***  THE CONSTANT RETURNED DEPENDS ON K...
C
C  ***        K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS.
C  ***        K = 2... SQUARE ROOT OF 1.001*ETA.
C  ***        K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH
C  ***                 THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1.
C  ***        K = 4... SQUARE ROOT OF 0.999*MACHEP.
C  ***        K = 5... SQUARE ROOT OF 0.999*BIG (SEE K = 6).
C  ***        K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS.
C
      DOUBLE PRECISION BIG, ETA, MACHEP
C/+
      DOUBLE PRECISION DSQRT
C/
      DOUBLE PRECISION ONE001, PT999
C
      DATA ONE001/1.001D0/, PT999/0.999D0/
C
C  +++  IBM 360, IBM 370, OR XEROX  +++
C
      DATA BIG/Z7FFFFFFFFFFFFFFF/, ETA/Z0010000000000000/,
     1     MACHEP/Z3410000000000000/
C
C  +++  DATA GENERAL  +++
C
C     DATA BIG/0.7237005577D+76/, ETA/0.5397605347D-78/,
C    1     MACHEP/2.22044605D-16/
C
C  +++  DEC 11  +++
C
C     DATA BIG/1.7D+38/, ETA/2.938735878D-39/, MACHEP/2.775557562D-17/
C
C  +++  HP3000  +++
C
C     DATA BIG/1.157920892D+77/, ETA/8.636168556D-78/,
C    1     MACHEP/5.551115124D-17/
C
C  +++  HONEYWELL  +++
C
C     DATA BIG/1.69D+38/, ETA/5.9D-39/, MACHEP/2.1680435D-19/
C
C  +++  DEC10  +++
C
C     DATA BIG/"377777100000000000000000/,
C    1     ETA/"002400400000000000000000/,
C    2     MACHEP/"104400000000000000000000/
C
C  +++  BURROUGHS  +++
C
C     DATA BIG/O0777777777777777,O7777777777777777/,
C    1     ETA/O1771000000000000,O7770000000000000/,
C    2     MACHEP/O1451000000000000,O0000000000000000/
C
C  +++  CONTROL DATA  +++
C
C
C     DATA BIG/37767777777777777777B,37167777777777777777B/,
C    1     ETA/00014000000000000000B,00000000000000000000B/,
C    2     MACHEP/15614000000000000000B,15010000000000000000B/
C
C  +++  PRIME  +++
C
C     DATA BIG/1.0D+9786/, ETA/1.0D-9860/, MACHEP/1.4210855D-14/
C
C  +++  UNIVAC  +++
C
C     DATA BIG/8.988D+307/, ETA/1.2D-308/, MACHEP/1.734723476D-18/
C
C  +++  VAX  +++
C
C     DATA BIG/1.7D+38/, ETA/2.939D-39/, MACHEP/1.3877788D-17/
C
C-------------------------------  BODY  --------------------------------
C
      GO TO (10, 20, 30, 40, 50, 60), K
C
 10   RMDCON = ETA
      GO TO 999
C
 20   RMDCON = DSQRT(ONE001*ETA)
      GO TO 999
C
 30   RMDCON = MACHEP
      GO TO 999
C
 40   RMDCON = DSQRT(PT999*MACHEP)
      GO TO 999
C
 50   RMDCON = DSQRT(PT999*BIG)
      GO TO 999
C
 60   RMDCON = BIG
C
 999  RETURN
C  ***  LAST CARD OF RMDCON FOLLOWS  ***
      END
C///////////////////////////////////////////////////////////////////////
      SUBROUTINE NL2SOL(N, P, X, CALCR, CALCJ, IV, V, UIPARM, URPARM,   NL200010
     1                  UFPARM)
C
C  ***  MINIMIZE NONLINEAR SUM OF SQUARES USING ANALYTIC JACOBIAN  ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
      INTEGER N, P, IV(1), UIPARM(1)
      DOUBLE PRECISION X(P), V(1), URPARM(1)
C     DIMENSION IV(60+P),  V(93 + N*P + 3*N + P*(3*P+33)/2)
C     DIMENSION UIPARM(*), URPARM(*)
      EXTERNAL CALCR, CALCJ, UFPARM
C
C  ***  PURPOSE  ***
C
C        GIVEN A P-VECTOR X OF PARAMETERS, CALCR COMPUTES AN N-VECTOR
C     R = R(X) OF RESIDUALS CORRESPONDING TO X.  (R(X) PROBABLY ARISES
C     FROM A NONLINEAR MODEL INVOLVING P PARAMETERS AND N OBSERVATIONS.)
C     THIS ROUTINE INTERACTS WITH NL2ITR TO SEEK A PARAMETER VECTOR X
C     THAT MINIMIZES THE SUM OF THE SQUARES OF (THE COMPONENTS OF) R(X),
C     I.E., THAT MINIMIZES THE SUM-OF-SQUARES FUNCTION
C     F(X) = (R(X)**T) * R(X) / 2.  R(X) IS ASSUMED TO BE A TWICE CON-
C     TINUOUSLY DIFFERENTIABLE FUNCTION OF X.
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C N........ (INPUT) THE NUMBER OF OBSERVATIONS, I.E., THE NUMBER OF
C                  COMPONENTS IN R(X).  N MUST BE .GE. P.
C P........ (INPUT) THE NUMBER OF PARAMETERS (COMPONENTS IN X).  P MUST
C                  BE POSITIVE.
C X........ (INPUT/OUTPUT).  ON INPUT, X IS AN INITIAL GUESS AT THE
C                  DESIRED PARAMETER ESTIMATE.  ON OUTPUT, X CONTAINS
C                  THE BEST PARAMETER ESTIMATE FOUND.
C CALCR.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES R(X).  CALCR
C                  MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
C                  IT IS INVOKED BY
C                       CALL CALCR(N,P,X,NF,R,UIPARM,URPARM,UFPARM)
C                  WHEN CALCR IS CALLED, NF IS THE INVOCATION COUNT
C                  FOR CALCR.  IT IS INCLUDED FOR POSSIBLE USE WITH
C                  CALCJ.  IF X IS OUT OF BOUNDS (E.G. IF IT WOULD
C                  CAUSE OVERFLOW IN COMPUTING R(X)), THEN CALCR SHOULD
C                  SET NF TO 0.  THIS WILL CAUSE A SHORTER STEP TO BE
C                  ATTEMPTED.  THE OTHER PARAMETERS ARE AS DESCRIBED
C                  ABOVE AND BELOW.  CALCR SHOULD NOT CHANGE N, P, OR X.
C CALCJ.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES THE JACOBIAN
C                  MATRIX J OF R AT X, I.E., THE N BY P MATRIX WHOSE
C                  (I,K) ENTRY IS THE PARTIAL DERIVATIVE OF THE I-TH
C                  COMPONENT OF R WITH RESPECT TO X(K).  CALCJ MUST BE
C                  DECLARED EXTERNAL IN THE CALLING PROGRAM.  IT IS
C                  INVOKED BY
C                       CALL CALCJ(N,P,X,NF,J,UIPARM,URPARM,UFPARM)
C                  NF IS THE INVOCATION COUNT FOR CALCR AT THE TIME
C                  R(X) WAS EVALUATED.  THE X PASSED TO CALCJ IS

 
C                  USUALLY THE ONE PASSED TO CALCR ON EITHER ITS MOST
C                  RECENT INVOCATION OR THE ONE PRIOR TO IT.  IF CALCR
C                  SAVES INTERMEDIATE RESULTS FOR USE BY CALCJ, THEN IT
C                  IS POSSIBLE TO TELL FROM NF WHETHER THEY ARE VALID
C                  FOR THE CURRENT X (OR WHICH COPY IS VALID IF TWO
C                  COPIES ARE KEPT).  IF J CANNOT BE COMPUTED AT X,
C                  THEN CALCJ SHOULD SET NF TO 0.  IN THIS CASE, NL2SOL
C                  WILL RETURN WITH IV(1) = 15.  THE OTHER PARAMETERS
C                  TO CALCJ ARE AS DESCRIBED ABOVE AND BELOW.  CALCJ
C                  SHOULD NOT CHANGE N, P, OR X.
C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH AT LEAST
C                  60 + P THAT HELPS CONTROL THE NL2SOL ALGORITHM AND
C                  THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI-
C                  TIES.  OF PARTICULAR INTEREST ARE THE INITIALIZATION/
C                  RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL
C                  PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC-
C                  TION EVALUATIONS.  SEE THE SECTION ON IV INPUT
C                  VALUES BELOW.
C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH AT
C                  LEAST 93 + N*P + 3*N + P*(3*P+33)/2 THAT HELPS CON-
C                  TROL THE NL2SOL ALGORITHM AND THAT IS USED TO STORE
C                  VARIOUS INTERMEDIATE QUANTITIES.  OF PARTICULAR IN-
C                  TEREST ARE THE ENTRIES IN V THAT LIMIT THE LENGTH OF
C                  THE FIRST STEP ATTEMPTED (LMAX0), SPECIFY CONVER-
C                  GENCE TOLERANCES (AFCTOL, RFCTOL, XCTOL, XFTOL),
C                  AND HELP CHOOSE THE STEP SIZE USED IN COMPUTING THE
C                  COVARIANCE MATRIX (DELTA0).  SEE THE SECTION ON
C                  (SELECTED) V INPUT VALUES BELOW.
C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE
C                  TO CALCR AND CALCJ.
C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT
C                  CHANGE TO CALCR AND CALCJ.
C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT
C                  CHANGE TO CALCR AND CALCJ.
C
C  ***  IV INPUT VALUES (FROM SUBROUTINE DFAULT)  ***
C
C IV(1)...  ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 12......
C             0 AND 12 MEAN THIS IS A FRESH START.  0 MEANS THAT
C             DFAULT(IV, V) IS TO BE CALLED TO PROVIDE ALL DEFAULT
C             VALUES TO IV AND V.  12 (THE VALUE THAT DFAULT ASSIGNS TO
C             IV(1)) MEANS THE CALLER HAS ALREADY CALLED DFAULT(IV, V)
C             AND HAS POSSIBLY CHANGED SOME IV AND/OR V ENTRIES TO NON-
C             DEFAULT VALUES.  DEFAULT = 12.
C IV(COVPRT)... IV(14) = 1 MEANS PRINT A COVARIANCE MATRIX AT THE SOLU-
C             TION.  (THIS MATRIX IS COMPUTED JUST BEFORE A RETURN WITH
C             IV(1) = 3, 4, 5, 6.)
C             IV(COVPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(COVREQ)... IV(15) = NONZERO MEANS COMPUTE A COVARIANCE MATRIX
C             JUST BEFORE A RETURN WITH IV(1) = 3, 4, 5, 6.  IN
C             THIS CASE, AN APPROXIMATE COVARIANCE MATRIX IS OBTAINED
C             IN ONE OF SEVERAL WAYS.  LET K = ABS(IV(COVREQ)) AND LET
C             SCALE = 2*F(X)/MAX(1,N-P),  WHERE 2*F(X) IS THE RESIDUAL
C             SUM OF SQUARES.  IF K = 1 OR 2, THEN A FINITE-DIFFERENCE
C             HESSIAN APPROXIMATION H IS OBTAINED.  IF H IS POSITIVE
C             DEFINITE (OR, FOR K = 3, IF THE JACOBIAN MATRIX J AT X
C             IS NONSINGULAR), THEN ONE OF THE FOLLOWING IS COMPUTED...
C                  K = 1....  SCALE * H**-1 * (J**T * J) * H**-1.
C                  K = 2....  SCALE * H**-1.
C                  K = 3....  SCALE * (J**T * J)**-1.
C             (J**T IS THE TRANSPOSE OF J, WHILE **-1 MEANS INVERSE.)
C             IF IV(COVREQ) IS POSITIVE, THEN BOTH FUNCTION AND GRAD-
C             IENT VALUES (CALLS ON CALCR AND CALCJ) ARE USED IN COM-
C             PUTING H (WITH STEP SIZES DETERMINED USING V(DELTA0) --
C             SEE BELOW), WHILE IF IV(COVREQ) IS NEGATIVE, THEN ONLY
C             FUNCTION VALUES (CALLS ON CALCR) ARE USED (WITH STEP
C             SIZES DETERMINED USING V(DLTFDC) -- SEE BELOW).  IF
C             IV(COVREQ) = 0, THEN NO ATTEMPT IS MADE TO COMPUTE A CO-
C             VARIANCE MATRIX (UNLESS IV(COVPRT) = 1, IN WHICH CASE
C             IV(COVREQ) = 1 IS ASSUMED).  SEE IV(COVMAT) BELOW.
C             DEFAULT = 1.
C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D (SEE REF. 1) SHOULD
C             BE CHOSEN.  IV(DTYPE) .GE. 1 MEANS CHOOSE D AS DESCRIBED
C             BELOW WITH V(DFAC).  IV(DTYPE) .LE. 0 MEANS THE CALLER
C             HAS CHOSEN D AND HAS STORED IT IN V STARTING AT
C             V(94 + 2*N + P*(3*P + 31)/2).  DEFAULT = 1.
C IV(INITS).... IV(25) TELLS HOW THE S MATRIX (SEE REF. 1) SHOULD BE
C             INITIALIZED.  0 MEANS INITIALIZE S TO 0 (AND START WITH
C             THE GAUSS-NEWTON MODEL).  1 AND 2 MEAN THAT THE CALLER
C             HAS STORED THE LOWER TRIANGLE OF THE INITIAL S ROWWISE IN
C             V STARTING AT V(87+2*P).  IV(INITS) = 1 MEANS START WITH
C             THE GAUSS-NEWTON MODEL, WHILE IV(INITS) = 2 MEANS START
C             WITH THE AUGMENTED MODEL (SEE REF. 1).  DEFAULT = 0.
C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS
C             (CALLS ON CALCR, EXCLUDING THOSE USED TO COMPUTE THE CO-
C             VARIANCE MATRIX) ALLOWED.  IF THIS NUMBER DOES NOT SUF-
C             FICE, THEN NL2SOL RETURNS WITH IV(1) = 9.  DEFAULT = 200.
C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C             IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA-
C             TIONS (CALLS ON CALCJ, EXCLUDING THOSE USED TO COMPUTE
C             THE COVARIANCE MATRIX) TO IV(MXITER) + 1.  IF IV(MXITER)
C             ITERATIONS DO NOT SUFFICE, THEN NL2SOL RETURNS WITH
C             IV(1) = 10.  DEFAULT = 150.
C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM-
C             MARY LINES PRINTED (BY ITSMRY).  IV(OUTLEV) = 0 MEANS DO
C             NOT PRINT ANY SUMMARY LINES.  OTHERWISE, PRINT A SUMMARY
C             LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS.  IF IV(OUTLEV)
C             IS POSITIVE, THEN SUMMARY LINES OF LENGTH 117 (PLUS CARRI-
C             AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING...  THE
C             ITERATION AND FUNCTION EVALUATION COUNTS, CURRENT FUNC-
C             TION VALUE (V(F) = HALF THE SUM OF SQUARES), RELATIVE
C             DIFFERENCE IN FUNCTION VALUES ACHIEVED BY THE LATEST STEP
C             (I.E., RELDF = (F0-V(F))/F0, WHERE F0 IS THE FUNCTION
C             VALUE FROM THE PREVIOUS ITERATION), THE RELATIVE FUNCTION
C             REDUCTION PREDICTED FOR THE STEP JUST TAKEN (I.E.,
C             PRELDF = V(PREDUC) / F0, WHERE V(PREDUC) IS DESCRIBED
C             BELOW), THE SCALED RELATIVE CHANGE IN X (SEE V(RELDX)
C             BELOW), THE MODELS USED IN THE CURRENT ITERATION (G =
C             GAUSS-NEWTON, S=AUGMENTED), THE MARQUARDT PARAMETER
C             STPPAR USED IN COMPUTING THE LAST STEP, THE SIZING FACTOR
C             USED IN UPDATING S, THE 2-NORM OF THE SCALE VECTOR D
C             TIMES THE STEP JUST TAKEN (SEE REF. 1), AND NPRELDF, I.E.,
C             V(NREDUC)/F0, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF
C             NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION
C             REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH
C             STPPAR = 0).  IF NPRELDF IS ZERO, EITHER THE GRADIENT
C             VANISHES (AS DOES PRELDF) OR ELSE THE AUGMENTED MODEL
C             IS BEING USED AND ITS HESSIAN IS INDEFINITE (WITH PRELDF
C             POSITIVE).  IF NPRELDF IS NEGATIVE, THEN IT IS THE NEGA-
C             OF THE RELATIVE FUNCTION REDUCTION PREDICTED FOR A STEP
C             COMPUTED WITH STEP BOUND V(LMAX0) FOR USE IN TESTING FOR
C             SINGULAR CONVERGENCE.
C                  IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF MAXIMUM
C             LENGTH 79 (OR 55 IS IV(COVPRT) = 0) ARE PRINTED, INCLUD-
C             ING ONLY THE FIRST 6 ITEMS LISTED ABOVE (THROUGH RELDX).
C             DEFAULT = 1.
C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A
C             FRESH START OR ANY CHANGED V VALUES ON A RESTART.
C             IV(PARPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING
C             IS DONE.  IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING.
C             (SETTING IV(PRUNIT) TO 0 IS THE ONLY WAY TO SUPPRESS THE
C             ONE-LINE TERMINATION REASON MESSAGE PRINTED BY ITSMRY.)
C             DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS).
C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS
C             WELL AS THE CORRESPONDING GRADIENT AND SCALE VECTOR D).
C             IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING.  DEFAULT = 1.
C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN-
C             ING.  THESE CONSIST OF THE FUNCTION VALUE (HALF THE SUM
C             OF SQUARES) AT X, V(RELDX) (SEE BELOW), THE NUMBER OF
C             FUNCTION AND GRADIENT EVALUATIONS (CALLS ON CALCR AND
C             CALCJ RESPECTIVELY, EXCLUDING ANY CALLS USED TO COMPUTE
C             THE COVARIANCE), THE RELATIVE FUNCTION REDUCTIONS PREDICT-
C             ED FOR THE LAST STEP TAKEN AND FOR A NEWTON STEP (OR PER-
C             HAPS A STEP BOUNDED BY V(LMAX0) -- SEE THE DESCRIPTIONS
C             OF PRELDF AND NPRELDF UNDER IV(OUTLEV) ABOVE), AND (IF AN
C             ATTEMPT WAS MADE TO COMPUTE THE COVARIANCE) THE NUMBER OF
C             CALLS ON CALCR AND CALCJ USED IN TRYING TO COMPUTE THE
C             COVARIANCE.  IV(STATPR) = 0 MEANS SKIP THIS PRINTING.
C             DEFAULT = 1.
C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D
C             (ON A FRESH START ONLY).  IV(X0PRT) = 0 MEANS SKIP THIS
C             PRINTING.  DEFAULT = 1.
C
C  ***  (SELECTED) IV OUTPUT VALUES  ***
C
C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE....
C             3 = X-CONVERGENCE.  THE SCALED RELATIVE DIFFERENCE BE-
C                  TWEEN THE CURRENT PARAMETER VECTOR X AND A LOCALLY
C                  OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT MOST
C                  V(XCTOL).
C             4 = RELATIVE FUNCTION CONVERGENCE.  THE RELATIVE DIFFER-
C                  ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO-
C                  CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL).
C             5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE
C                  CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD).
C             6 = ABSOLUTE FUNCTION CONVERGENCE.  THE CURRENT FUNCTION
C                  VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE.
C             7 = SINGULAR CONVERGENCE.  THE HESSIAN NEAR THE CURRENT
C                  ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A
C                  STEP OF LENGTH AT MOST V(LMAX0) IS UNLIKELY TO YIELD
C                  A RELATIVE FUNCTION DECREASE OF MORE THAN V(RFCTOL).
C             8 = FALSE CONVERGENCE.  THE ITERATES APPEAR TO BE CONVERG-
C                  ING TO A NONCRITICAL POINT.  THIS MAY MEAN THAT THE
C                  CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL),
C                  V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH
C                  THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT
C                  THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT
C                  THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X.
C             9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON-
C                  VERGENCE (SEE IV(MXFCAL)).
C            10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE
C                  (SEE IV(MXITER)).
C            11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT).  SEE THE
C                  USAGE NOTES BELOW.
C            13 = F(X) CANNOT BE COMPUTED AT THE INITIAL X.
C            14 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT
C                  OCCUR).
C            15 = THE JACOBIAN COULD NOT BE COMPUTED AT X (SEE CALCJ
C                  ABOVE).
C            16 = N OR P (OR PARAMETER NN TO NL2ITR) OUT OF RANGE --
C                  P .LE. 0 OR N .LT. P OR NN .LT. N.
C            17 = RESTART ATTEMPTED WITH N OR P (OR PAR. NN TO NL2ITR)
C                  CHANGED.
C            18 = IV(INITS) IS OUT OF RANGE.
C            19...45 = V(IV(1)) IS OUT OF RANGE.
C            50 = IV(1) WAS OUT OF RANGE.
C            87...(86+P) = JTOL(IV(1)-86) (I.E., V(IV(1)) IS NOT
C                  POSITIVE (SEE V(DFAC) BELOW).
C IV(COVMAT)... IV(26) TELLS WHETHER A COVARIANCE MATRIX WAS COMPUTED.
C             IF (IV(COVMAT) IS POSITIVE, THEN THE LOWER TRIANGLE OF
C             THE COVARIANCE MATRIX IS STORED ROWWISE IN V STARTING AT
C             V(IV(COVMAT)).  IF IV(COVMAT) = 0, THEN NO ATTEMPT WAS
C             MADE TO COMPUTE THE COVARIANCE.  IF IV(COVMAT) = -1,
C             THEN THE FINITE-DIFFERENCE HESSIAN WAS INDEFINITE.  AND
C             AND IF IV(COVMAT) = -2, THEN A SUCCESSFUL FINITE-DIFFER-
C             ENCING STEP COULD NOT BE FOUND FOR SOME COMPONENT OF X
C             (I.E., CALCR SET NF TO 0 FOR EACH OF TWO TRIAL STEPS).
C             NOTE THAT IV(COVMAT) IS RESET TO 0 AFTER EACH SUCCESSFUL
C             STEP, SO IF SUCH A STEP IS TAKEN AFTER A RESTART, THEN
C             THE COVARIANCE MATRIX WILL BE RECOMPUTED.
C IV(D)........ IV(27) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
C             SCALE VECTOR D.
C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
C             LEAST-SQUARES GRADIENT VECTOR (J**T)*R.
C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCR (I.E.,
C             FUNCTION EVALUATIONS, INCLUDING THOSE USED IN COMPUTING
C             THE COVARIANCE).
C IV(NFCOV).... IV(40) IS THE NUMBER OF CALLS MADE ON CALCR WHEN
C             TRYING TO COMPUTE COVARIANCE MATRICES.
C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON
C             CALCJ) SO FAR DONE (INCLUDING THOSE USED FOR COMPUTING
C             THE COVARIANCE).
C IV(NGCOV).... IV(41) IS THE NUMBER OF CALLS MADE ON CALCJ WHEN
C             TRYING TO COMPUTE COVARIANCE MATRICES.
C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED.
C IV(R)........ IV(50) IS THE STARTING SUBSCRIPT IN V OF THE RESIDUAL
C             VECTOR R CORRESPONDING TO X.
C
C  ***  (SELECTED) V INPUT VALUES (FROM SUBROUTINE DFAULT)  ***
C
C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.
C             IF NL2SOL FINDS A POINT WHERE THE FUNCTION VALUE (HALF
C             THE SUM OF SQUARES) IS LESS THAN V(AFCTOL), AND IF NL2SOL
C             DOES NOT RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS
C             WITH IV(1) = 6.  DEFAULT = MAX(10**-20, MACHEP**2), WHERE
C             MACHEP IS THE UNIT ROUNDOFF.
C V(DELTA0)... V(44) IS A FACTOR USED IN CHOOSING THE FINITE-DIFFERENCE
C             STEP SIZE USED IN COMPUTING THE COVARIANCE MATRIX WHEN
C             IV(COVREQ) = 1 OR 2.  FOR COMPONENT I, STEP SIZE
C                  V(DELTA0) * MAX(ABS(X(I)), 1/D(I)) * SIGN(X(I))
C             IS USED, WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).
C             (IF THIS STEP RESULTS IN CALCR SETTING NF TO 0, THEN -0.5
C             TIMES THIS STEP IS ALSO TRIED.)  DEFAULT = MACHEP**0.5,
C             WHERE MACHEP IS THE UNIT ROUNDOFF.
C V(DFAC)..... V(41) AND THE D0 AND JTOL ARRAYS (SEE V(D0INIT) AND
C             V(JTINIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
C             IV(DTYPE) .GT. 0.  (D IS INITIALIZED ACCORDING TO
C             V(DINIT).)  LET D1(I) =
C               MAX(SQRT(JCNORM(I)**2 + MAX(S(I,I),0)), V(DFAC)*D(I)),
C             WHERE JCNORM(I) IS THE 2-NORM OF THE I-TH COLUMN OF THE
C             CURRENT JACOBIAN MATRIX AND S IS THE S MATRIX OF REF. 1.
C             IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) UNLESS
C             D1(I) .LT. JTOL(I), IN WHICH CASE D(I) IS SET TO
C                                MAX(D0(I), JTOL(I)).
C             IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
C             ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
C             DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
C             DEFAULT = 0.6.
C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE
C             VECTOR D IS INITIALIZED.  DEFAULT = 0.
C V(DLTFDC)... V(40) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
C             COVARIANCE MATRIX WHEN IV(COVREQ) = -1 OR -2.  FOR
C             DIFFERENCES INVOLVING X(I), THE STEP SIZE FIRST TRIED IS
C                       V(DLTFDC) * MAX(ABS(X(I)), 1/D(I)),
C             WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).  (IF
C             THIS STEP IS TOO BIG THE FIRST TIME IT IS TRIED, I.E., IF
C             CALCR SETS NF TO 0, THEN -0.5 TIMES THIS STEP IS ALSO
C             TRIED.)  DEFAULT = MACHEP**(1/3), WHERE MACHEP IS THE
C             UNIT ROUNDOFF.
C V(D0INIT)... V(37), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
C             OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED.  IF
C             V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
C             STORED D0 IN V STARTING AT V(P+87).  DEFAULT = 1.0.
C V(JTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
C             OF THE JTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED.  IF
C             V(JTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
C             STORED JTOL IN V STARTING AT V(87).  DEFAULT = 10**-6.
C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE
C             VERY FIRST STEP THAT NL2SOL ATTEMPTS.  IT IS ALSO USED
C             IN TESTING FOR SINGULAR CONVERGENCE -- IF THE FUNCTION
C             REDUCTION PREDICTED FOR A STEP OF LENGTH BOUNDED BY
C             V(LMAX0) IS AT MOST V(RFCTOL) * ABS(F0), WHERE  F0  IS
C             THE FUNCTION VALUE AT THE START OF THE CURRENT ITERATION,
C             AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, OR 6,
C             THEN IT RETURNS WITH IV(1) = 7.    DEFAULT = 100.
C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE.
C             IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION
C             REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) AT
C             THE START OF THE CURRENT ITERATION, WHERE  F0  IS THE
C             THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT-
C             ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION
C             DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 4 (OR 5).
C             DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS
C             THE UNIT ROUNDOFF.
C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE
C             AND TO CONSIDER SWITCHING MODELS.  THIS IS DONE IF THE
C             ACTUAL FUNCTION DECREASE FROM THE CURRENT STEP IS NO MORE
C             THAN V(TUNER1) TIMES ITS PREDICTED VALUE.  DEFAULT = 0.1.
C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE.  IF A NEWTON STEP
C             (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL)
C             AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC-
C             TION DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 3 (OR 5).
C             (SEE THE DESCRIPTION OF V(RELDX) BELOW.)
C             DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF.
C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE.  IF A STEP IS
C             TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT-
C             ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL),
C             AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR
C             7, THEN IT RETURNS WITH IV(1) = 8.  (SEE THE DESCRIPTION
C             OF V(RELDX) BELOW.)  DEFAULT = 100*MACHEP, WHERE
C             MACHEP IS THE UNIT ROUNDOFF.
C V(*)........ DFAULT SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH
C             WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER.  SEE
C             VERSION 2.2 OF THE NL2SOL USAGE SUMMARY (WHICH IS AN
C             APPENDIX TO REF. 1).
C
C  ***  (SELECTED) V OUTPUT VALUES  ***
C
C V(DGNORM)... V(1) IS THE 2-NORM OF (D**-1)*G, WHERE G IS THE MOST RE-
C             CENTLY COMPUTED GRADIENT AND D IS THE CORRESPONDING SCALE
C             VECTOR.
C V(DSTNRM)... V(2) IS THE 2-NORM OF D*STEP, WHERE STEP IS THE MOST RE-
C             CENTLY COMPUTED STEP AND D IS THE CURRENT SCALE VECTOR.
C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE (HALF THE SUM OF
C             SQUARES).
C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT
C             ITERATION.
C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION
C             POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC-
C             TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E.,
C             STEP = -H**-1 * G,  WHERE  G = (J**T) * R  IS THE CURRENT
C             GRADIENT AND H IS THE CURRENT HESSIAN APPROXIMATION --
C             H = (J**T)*J  FOR THE GAUSS-NEWTON MODEL AND
C             H = (J**T)*J + S  FOR THE AUGMENTED MODEL).
C                  V(NREDUC) = ZERO MEANS H IS NOT POSITIVE DEFINITE.
C                  IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF
C             THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH
C             A STEP BOUND OF V(LMAX0) FOR USE IN TESTING FOR SINGULAR
C             CONVERGENCE.
C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT
C             QUADRATIC MODEL) FOR THE CURRENT STEP.  THIS (DIVIDED BY
C             V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION
C             CONVERGENCE.
C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE
C             CURRENT STEP, COMPUTED AS
C                  MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) /
C                     MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P),
C             WHERE X = X0 + STEP.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE REF. 1 FOR A DESCRIPTION OF THE ALGORITHM USED.
C        ON PROBLEMS WHICH ARE NATURALLY WELL SCALED, BETTER PERFORM-
C     ANCE MAY BE OBTAINED BY SETTING V(D0INIT) = 1.0 AND IV(DTYPE) = 0,
C     WHICH WILL CAUSE THE SCALE VECTOR D TO BE SET TO ALL ONES.
C
C  ***  USAGE NOTES  ***
C
C        AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART,
C     I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE
C     AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT-
C     ED.  IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV
C     AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DFAULT).
C        THOSE WHO DO NOT WISH TO WRITE A CALCJ WHICH COMPUTES THE JA-
C     COBIAN MATRIX ANALYTICALLY SHOULD CALL NL2SNO RATHER THAN NL2SOL.
C     NL2SNO USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE JACOBIAN.
C        THOSE WHO WOULD PREFER TO PROVIDE R AND J (THE RESIDUAL AND
C     JACOBIAN) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU-
C     TINES CALCR AND CALCJ MAY CALL ON NL2ITR DIRECTLY.  SEE THE COM-
C     MENTS AT THE BEGINNING OF NL2ITR.
C        THOSE WHO USE NL2SOL INTERACTIVELY MAY WISH TO SUPPLY THEIR
C     OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY
C     HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED.  THIS MAKES IT POS-
C     SIBLE TO EXTERNALLY INTERRUPT NL2SOL (WHICH WILL RETURN WITH
C     IV(1) = 11 IF STOPX RETURNS .TRUE.).
C        STORAGE FOR J IS ALLOCATED AT THE END OF V.  THUS THE CALLER
C     MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCJ TO USE
C     ELEMENTS OF J BEYOND THE FIRST N*P AS SCRATCH STORAGE.
C
C  ***  PORTABILITY NOTES  ***
C
C        THE NL2SOL DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE-
C     PRECISION VERSIONS OF THE NL2SOL SOURCE CODE, SO IT SHOULD BE UN-
C     NECESSARY TO CHANGE PRECISIONS.
C        ONLY THE FUNCTIONS IMDCON AND RMDCON CONTAIN MACHINE-DEPENDENT
C     CONSTANTS.  TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD
C     SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS.
C        INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED.  ON CERTAIN COM-
C     PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE
C     DECLARATIONS.  SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE
C     PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+
C     IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY
C     A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72.
C        THE NL2SOL SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD
C     FORTRAN.  IT MAY BE CONVERTED TO FORTRAN 77 BY
C     COMMENTING OUT ALL LINES THAT FALL BETWEEN A LINE HAVING C/6 IN
C     COLUMNS 1-3 AND A LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING
C     (I.E., REPLACING BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT
C     FOLLOW THE C/7 LINE AND PRECEED A LINE HAVING C/ IN COLUMNS 1-2
C     AND BLANKS IN COLUMNS 3-72.  THESE CHANGES CONVERT SOME DATA
C     STATEMENTS INTO PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM
C     REAL TO CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE
C     THESE VARIABLES USE CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD
C     OF HOLLERITH CONSTANTS.  (SUCH VARIABLES AND DATA STATEMENTS
C     APPEAR ONLY IN MODULES ITSMRY AND PARCHK.  PARAMETER STATEMENTS
C     APPEAR NEARLY EVERYWHERE.)
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY (WINTER 1979 - WINTER 1980).
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C----------------------------  DECLARATIONS  ---------------------------
C
      EXTERNAL ITSMRY, NL2ITR
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO-
C             RITHM.
C
      LOGICAL STRTED
      INTEGER D1, J1, NF, R1
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER D, J, NFCALL, NFGCAL, R, TOOBIG
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA NFCALL/6/, NFGCAL/7/, TOOBIG/2/
C/7
C     PARAMETER (NFCALL=6, NFGCAL=7, TOOBIG=2)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA D/27/, J/33/, R/50/
C/7
C     PARAMETER (D=27, J=33, R=50)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      D1 = 94 + 2*N + P*(3*P + 31)/2
      IV(D) = D1
      R1 = D1 + P
      IV(R) = R1
      J1 = R1 + N
      IV(J) = J1
      STRTED = .TRUE.
      IF (IV(1) .NE. 0 .AND. IV(1) .NE. 12) GO TO 40
         STRTED = .FALSE.
         IV(NFCALL) = 1
         IV(NFGCAL) = 1
C
 10   NF = IV(NFCALL)
      CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
      IF (STRTED) GO TO 20
         IF (NF .GT. 0) GO TO 30
              IV(1) = 13
              GO TO 60
C
 20   IF (NF .LE. 0) IV(TOOBIG) = 1
      GO TO 40
C
 30   CALL CALCJ(N, P, X, IV(NFGCAL), V(J1), UIPARM, URPARM, UFPARM)
      IF (IV(NFGCAL) .EQ. 0) GO TO 50
      STRTED = .TRUE.
C
 40   CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X)
      IF (IV(1) - 2) 10, 30, 999
C
 50   IV(1) = 15
 60   CALL ITSMRY(V(D1), IV, P, V, X)
C
 999  RETURN
C  ***  LAST CARD OF NL2SOL FOLLOWS  ***
      END
      SUBROUTINE NL2SNO(N, P, X, CALCR, IV, V, UIPARM, URPARM, UFPARM)  SNO00010
C
C  ***  LIKE NL2SOL, BUT WITHOUT CALCJ -- MINIMIZE NONLINEAR SUM OF  ***
C  ***  SQUARES USING FINITE-DIFFERENCE JACOBIAN APPROXIMATIONS      ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
      INTEGER N, P, IV(1), UIPARM(1)
      DOUBLE PRECISION X(P), V(1), URPARM(1)
C     DIMENSION IV(60+P),  V(93 + N*P + 3*N + P*(3*P+33)/2)
      EXTERNAL CALCR, UFPARM
C
C-----------------------------  DISCUSSION  ----------------------------
C
C        THE PARAMETERS FOR NL2SNO ARE THE SAME AS THOSE FOR NL2SOL
C     (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED.  INSTEAD OF CALLING
C     CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, NL2SNO COMPUTES
C     AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
C     V(DLTFDJ) BELOW.  NL2SNO USES FUNCTION VALUES ONLY WHEN COMPUT-
C     THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS
C     THAT NL2SOL MAY USE).  TO DO SO, NL2SNO SETS IV(COVREQ) TO -1 IF
C     IV(COVPRT) = 1 WITH IV(COVREQ) = 0 AND TO MINUS ITS ABSOLUTE
C     VALUE OTHERWISE.  THUS V(DELTA0) IS NEVER REFERENCED AND ONLY
C     V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC).
C        THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
C     BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
C     COUNT IV(NFCALL) AND ARE NOT OTHERWISE REPORTED.
C
C V(DLTFDJ)... V(36) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
C             FINITE-DIFFERENCE JACOBIAN MATRIX.  FOR DIFFERENCES IN-
C             VOLVING X(I), THE STEP SIZE FIRST TRIED IS
C                       V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
C             WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1).  (IF
C             THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
C             SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
C             LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
C             DEFAULT = MACHEP**0.5.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++  DECLARATIONS  ++++++++++++++++++++++++++++
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      DOUBLE PRECISION DABS, DMAX1
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DFAULT, ITSMRY, NL2ITR, RMDCON, VSCOPY
      DOUBLE PRECISION RMDCON
C
C DFAULT... SUPPLIES DEFAULT PARAMETER VALUES.
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO-
C             RITHM.
C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
      LOGICAL STRTED
      INTEGER DK, D1, I, J1, J1K, K, NF, RN, R1, DINIT
      DOUBLE PRECISION H, HFAC, HLIM, NEGPT5, ONE, XK, ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER COVPRT, COVREQ, D, DLTFDJ, DTYPE, J, NFCALL, NFGCAL, R,
     1        TOOBIG
C
C/6
      DATA HFAC/1.D+3/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (HFAC=1.D+3, NEGPT5=-0.5D+0, ONE=1.D+0, ZERO=0.D+0)
C/
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA COVPRT/14/, COVREQ/15/, D/27/, DTYPE/16/, J/33/,
     1     NFCALL/6/, NFGCAL/7/, R/50/, TOOBIG/2/
C/7
C     PARAMETER (COVPRT=14, COVREQ=15, D=27, DTYPE=16, J=33,
C    1     NFCALL=6, NFGCAL=7, R=50, TOOBIG=2)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA DLTFDJ/36/, DINIT/38/
C/7
C     PARAMETER (DLTFDJ=36)
C     SAVE HLIM
C/
      DATA HLIM/0.D+0/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      D1 = 94 + 2*N + P*(3*P + 31)/2
      IV(D) = D1
      R1 = D1 + P
      IV(R) = R1
      J1 = R1 + N
      IV(J) = J1
      RN = J1 - 1
      IF (IV(1) .EQ. 0) CALL DFAULT(IV, V)
      IV(COVREQ) = -IABS(IV(COVREQ))
      IF (IV(COVPRT) .NE. 0 .AND. IV(COVREQ) .EQ. 0) IV(COVREQ) = -1
      STRTED = .TRUE.
      IF (IV(1) .NE. 12) GO TO 80
         STRTED = .FALSE.
         IV(NFCALL) = 1
         IV(NFGCAL) = 1
C        ***  INITIALIZE SCALE VECTOR D TO ONES FOR COMPUTING
C        ***  INITIAL JACOBIAN.
         IF (IV(DTYPE) .GT. 0) CALL VSCOPY(P, V(D1), ONE)
       IF (V(DINIT).GT.ZERO) CALL VSCOPY(P, V(D1), V(DINIT))
C
 10   NF = IV(NFCALL)
      CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
      IF (STRTED) GO TO 20
         IF (NF .GT. 0) GO TO 30
              IV(1) = 13
              GO TO 90
C
 20   IF (NF .LE. 0) IV(TOOBIG) = 1
      GO TO 80
C
C  ***  COMPUTE FINITE-DIFFERENCE JACOBIAN  ***
C
 30   J1K = J1
      DK = D1
      DO 70 K = 1, P
         XK = X(K)
         H = V(DLTFDJ) * DMAX1(DABS(XK), ONE/V(DK))
         DK = DK + 1
 40      X(K) = XK + H
         NF = IV(NFGCAL)
         CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM)
         IF (NF .GT. 0) GO TO 50
              IF (HLIM .EQ. ZERO) HLIM = HFAC * RMDCON(3)
C             ***  HLIM = HFAC TIMES THE UNIT ROUNDOFF  ***
              H = NEGPT5 * H
              IF (DABS(H) .GE. HLIM) GO TO 40
                   IV(1) = 15
                   GO TO 90
 50      X(K) = XK
         DO 60 I = R1, RN
              V(J1K) = (V(J1K) - V(I)) / H
              J1K = J1K + 1
 60           CONTINUE
 70      CONTINUE
C
      STRTED = .TRUE.
C
 80   CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X)
      IF (IV(1) - 2) 10, 30, 999
C
 90   CALL ITSMRY(V(D1), IV, P, V, X)
C
 999  RETURN
C  ***  LAST CARD OF NL2SNO FOLLOWS  ***
      END
      SUBROUTINE NL2ITR (D, IV, J, N, NN, P, R, V, X)                   ITR00010
C
C  ***  CARRY OUT NL2SOL (NONLINEAR LEAST-SQUARES) ITERATIONS  ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IV(1), N, NN, P
      DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P)
C     DIMENSION IV(60+P), V(93 + 2*N + P*(3*P+31)/2)
C
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C D.... SCALE VECTOR.
C IV... INTEGER VALUE ARRAY.
C J.... N BY P JACOBIAN MATRIX (LEAD DIMENSION NN).
C N.... NUMBER OF OBSERVATIONS (COMPONENTS IN R).
C NN... LEAD DIMENSION OF J.
C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
C R.... RESIDUAL VECTOR.
C V.... FLOATING-POINT VALUE ARRAY.
C X.... PARAMETER VECTOR.
C
C  ***  DISCUSSION  ***
C
C        PARAMETERS IV, N, P, V, AND X ARE THE SAME AS THE CORRESPOND-
C     ING ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER
C     (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS
C     NOT NEEDED).  MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE
C     TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW,
C     AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL).  THE VALUES IV(D),
C     IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND
C     NL2SNO), ARE NOT REFERENCED BY NL2ITR OR THE SUBROUTINES IT CALLS.
C        ON A FRESH START, I.E., A CALL ON NL2ITR WITH IV(1) = 0 OR 12,
C     NL2ITR ASSUMES THAT R = R(X), THE RESIDUAL AT X, AND J = J(X),
C     THE CORRESPONDING JACOBIAN MATRIX OF R AT X.
C
C IV(1) = 1 MEANS THE CALLER SHOULD SET R TO R(X), THE RESIDUAL AT X,
C             AND CALL NL2ITR AGAIN, HAVING CHANGED NONE OF THE OTHER
C             PARAMETERS.  AN EXCEPTION OCCURS IF R CANNOT BE EVALUATED
C             AT X (E.G. IF R WOULD OVERFLOW), WHICH MAY HAPPEN BECAUSE
C             OF AN OVERSIZED STEP.  IN THIS CASE THE CALLER SHOULD SET
C             IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE NL2ITR TO IG-
C             NORE R AND TRY A SMALLER STEP.  THE PARAMETER NF THAT
C             NL2SOL PASSES TO CALCR (FOR POSSIBLE USE BY CALCJ) IS A
C             COPY OF IV(NFCALL) = IV(6).
C IV(1) = 2 MEANS THE CALLER SHOULD SET J TO J(X), THE JACOBIAN MATRIX
C             OF R AT X, AND CALL NL2ITR AGAIN.  THE CALLER MAY CHANGE
C             D AT THIS TIME, BUT SHOULD NOT CHANGE ANY OF THE OTHER
C             PARAMETERS.  THE PARAMETER NF THAT NL2SOL PASSES TO
C             CALCJ IS IV(NFGCAL) = IV(7).  IF J CANNOT BE EVALUATED
C             AT X, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH
C             CASE NL2ITR WILL RETURN WITH IV(1) = 15.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C        (SEE NL2SOL FOR REFERENCES.)
C
C+++++++++++++++++++++++++++  DECLARATIONS  ++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER DUMMY, DIG1, G1, G01, H0, H1, I, IM1, IPIVI, IPIVK, IPIV1,
     1        IPK, K, KM1, L, LKY1, LMAT1, LSTGST, M, PP1O2, QTR1,
     2        RDK, RD0, RD1, RSAVE1, SMH, SSTEP, STEP1, STPMOD, S1,
     3        TEMP1, TEMP2, W1, X01
      DOUBLE PRECISION E, RDOF1, STTSST, T, T1
C
C     ***  CONSTANTS  ***
C
      DOUBLE PRECISION HALF, NEGONE, ONE, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      DOUBLE PRECISION DABS
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL ASSESS, COVCLC, DOTPRD, DUPDAT, GQTSTP, ITSMRY, LMSTEP,
     1         PARCHK, QAPPLY, QRFACT, RPTMUL, SLUPDT, SLVMUL, STOPX,
     2         VAXPY, VCOPY, VSCOPY, V2NORM
      LOGICAL STOPX
      DOUBLE PRECISION DOTPRD, V2NORM
C
C ASSESS... ASSESSES CANDIDATE STEP.
C COVCLC... COMPUTES COVARIANCE MATRIX.
C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS.
C DUPDAT... UPDATES SCALE VECTOR D.
C GQTSTP... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C LMSTEP... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
C PARCHK... CHECKS VALIDITY OF INPUT IV AND V VALUES.
C QAPPLY... APPLIES ORTHOGONAL MATRIX Q FROM QRFACT TO A VECTOR.
C QRFACT... COMPUTES QR DECOMPOSITION OF A MATRIX VIA HOUSEHOLDER TRANS.
C RPTMUL... MULTIPLIES VECTOR BY THE R MATRIX (AND/OR ITS TRANSPOSE)
C             STORED BY QRFACT.
C SLUPDT... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
C             ANGLE OF A SYMMETRIC MATRIX.
C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
C VAXPY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
C VCOPY.... COPIES ONE VECTOR TO ANOTHER.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C V2NORM... RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER CNVCOD, COSMIN, COVMAT, COVPRT, COVREQ, DGNORM, DIG,
     1        DINIT, DSTNRM, DTYPE, D0INIT, F, FDIF, FUZZ,
     2        F0, G, GTSTEP, H, IERR, INCFAC, INITS, IPIVOT, IPIV0, IRC,
     3        JTINIT, JTOL1, KAGQT, KALM, LKY, LMAT, LMAX0, MODE, MODEL,
     4        MXFCAL, MXITER, NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL,
     5        NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, RADINC,
     6        RADIUS, RAD0, RD, RESTOR, RLIMIT, RSAVE, S, SIZE, STEP,
     7        STGLIM, STLSTG, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4,
     8        TUNER5, VSAVE1, W, WSCALE, XIRC, X0
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA CNVCOD/34/, COVMAT/26/, COVPRT/14/,
     1     COVREQ/15/, DIG/43/, DTYPE/16/, G/28/, H/44/,
     2     IERR/32/, INITS/25/, IPIVOT/61/, IPIV0/60/,
     3     IRC/3/, KAGQT/35/, KALM/36/, LKY/37/, LMAT/58/,
     4     MODE/38/, MODEL/5/, MXFCAL/17/, MXITER/18/,
     5     NFCALL/6/, NFGCAL/7/, NFCOV/40/, NGCOV/41/,
     6     NGCALL/30/, NITER/31/, QTR/49/,
     7     RADINC/8/, RD/51/, RESTOR/9/, RSAVE/52/, S/53/,
     8     STEP/55/, STGLIM/11/, STLSTG/56/, SUSED/57/,
     9     SWITCH/12/, TOOBIG/2/, W/59/, XIRC/13/, X0/60/
C/7
C     PARAMETER (CNVCOD=34, COVMAT=26, COVPRT=14,
C    1     COVREQ=15, DIG=43, DTYPE=16, G=28, H=44,
C    2     IERR=32, INITS=25, IPIVOT=61, IPIV0=60,
C    3     IRC=3, KAGQT=35, KALM=36, LKY=37, LMAT=58,
C    4     MODE=38, MODEL=5, MXFCAL=17, MXITER=18,
C    5     NFCALL=6, NFGCAL=7, NFCOV=40, NGCOV=41,
C    6     NGCALL=30, NITER=31, QTR=49,
C    7     RADINC=8, RD=51, RESTOR=9, RSAVE=52, S=53,
C    8     STEP=55, STGLIM=11, STLSTG=56, SUSED=57,
C    9     SWITCH=12, TOOBIG=2, W=59, XIRC=13, X0=60)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA COSMIN/43/, DGNORM/1/, DINIT/38/, DSTNRM/2/,
     1     D0INIT/37/, F/10/, FDIF/11/, FUZZ/45/,
     2     F0/13/, GTSTEP/4/, INCFAC/23/,
     3     JTINIT/39/, JTOL1/87/, LMAX0/35/,
     4     NVSAVE/9/, PHMXFC/21/, PREDUC/7/,
     5     RADFAC/16/, RADIUS/8/, RAD0/9/, RLIMIT/42/,
     6     SIZE/47/, STPPAR/5/, TUNER4/29/, TUNER5/30/,
     7     VSAVE1/78/, WSCALE/48/
C/7
C     PARAMETER (COSMIN=43, DGNORM=1, DINIT=38, DSTNRM=2,
C    1     D0INIT=37, F=10, FDIF=11, FUZZ=45,
C    2     F0=13, GTSTEP=4, INCFAC=23,
C    3     JTINIT=39, JTOL1=87, LMAX0=35,
C    4     NVSAVE=9, PHMXFC=21, PREDUC=7,
C    5     RADFAC=16, RADIUS=8, RAD0=9, RLIMIT=42,
C    6     SIZE=47, STPPAR=5, TUNER4=29, TUNER5=30,
C    7     VSAVE1=78, WSCALE=48)
C/
C
C
C/6
      DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0)
C/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      I = IV(1)
      IF (I .EQ. 1) GO TO 20
      IF (I .EQ. 2) GO TO 50
C
C  ***  CHECK VALIDITY OF IV AND V INPUT VALUES  ***
C
C     ***  NOTE -- IF IV(1) = 0, THEN PARCHK CALLS DFAULT(IV, V)  ***
      CALL PARCHK(IV, N, NN, P, V)
      I = IV(1) - 2
      IF (I .GT. 10) GO TO 999
      GO TO (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), I
C
C  ***  INITIALIZATION AND STORAGE ALLOCATION  ***
C
 10   IV(NITER) = 0
      IV(NFCALL) = 1
      IV(NGCALL) = 1
      IV(NFGCAL) = 1
      IV(MODE) = -1
      IV(STGLIM) = 2
      IV(TOOBIG) = 0
      IV(CNVCOD) = 0
      IV(COVMAT) = 0
      IV(NFCOV) = 0
      IV(NGCOV) = 0
      IV(KALM) = -1
      IV(RADINC) = 0
      IV(S) = JTOL1 + 2*P
      PP1O2 = P * (P + 1) / 2
      IV(X0) = IV(S) + PP1O2
      IV(STEP) = IV(X0) + P
      IV(STLSTG) = IV(STEP) + P
      IV(DIG) = IV(STLSTG) + P
      IV(G) = IV(DIG) + P
      IV(LKY) = IV(G) + P
      IV(RD) = IV(LKY) + P
      IV(RSAVE) = IV(RD) + P
      IV(QTR) = IV(RSAVE) + N
      IV(H) = IV(QTR) + N
      IV(W) = IV(H) + PP1O2
      IV(LMAT) = IV(W) + 4*P + 7
C     +++ LENGTH OF W = P*(P+9)/2 + 7.  LMAT IS CONTAINED IN W.
      IF (V(DINIT) .GE. ZERO) CALL VSCOPY(P, D, V(DINIT))
      IF (V(JTINIT) .GT. ZERO) CALL VSCOPY(P, V(JTOL1), V(JTINIT))
      I = JTOL1 + P
      IF (V(D0INIT) .GT. ZERO) CALL VSCOPY(P, V(I), V(D0INIT))
      V(RAD0) = ZERO
      V(STPPAR) = ZERO
      V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
C
C  ***  SET INITIAL MODEL AND S MATRIX  ***
C
      IV(MODEL) = 1
      IF (IV(INITS) .EQ. 2) IV(MODEL) = 2
      S1 = IV(S)
      IF (IV(INITS) .EQ. 0) CALL VSCOPY(PP1O2, V(S1), ZERO)
C
C  ***  COMPUTE FUNCTION VALUE (HALF THE SUM OF SQUARES)  ***
C
 20   T = V2NORM(N, R)
      IF (T .GT. V(RLIMIT)) IV(TOOBIG) = 1
      IF (IV(TOOBIG) .NE. 0) GO TO 30
      V(F) = HALF * T**2
 30   IF (IV(MODE)) 40, 350, 730
C
 40   IF (IV(TOOBIG) .EQ. 0) GO TO 60
         IV(1) = 13
         GO TO 900
C
C  ***  MAKE SURE JACOBIAN COULD BE COMPUTED  ***
C
 50   IF (IV(NFGCAL) .NE. 0) GO TO 60
         IV(1) = 15
         GO TO 900
C
C  ***  COMPUTE GRADIENT  ***
C
 60   IV(KALM) = -1
      G1 = IV(G)
      DO 70 I = 1, P
         V(G1) = DOTPRD(N, R, J(1,I))
         G1 = G1 + 1
 70      CONTINUE
      IF (IV(MODE) .GT. 0) GO TO 710
C
C  ***  UPDATE D AND MAKE COPIES OF R FOR POSSIBLE USE LATER  ***
C
      IF (IV(DTYPE) .GT. 0) CALL DUPDAT(D, IV, J, N, NN, P, V)
      RSAVE1 = IV(RSAVE)
      CALL VCOPY(N, V(RSAVE1), R)
      QTR1 = IV(QTR)
      CALL VCOPY(N, V(QTR1), R)
C
C  ***  COMPUTE  D**-1 * GRADIENT  ***
C
      G1 = IV(G)
      DIG1 = IV(DIG)
      K = DIG1
      DO 80 I = 1, P
         V(K) = V(G1) / D(I)
         K = K + 1
         G1 = G1 + 1
 80      CONTINUE
      V(DGNORM) = V2NORM(P, V(DIG1))
C
      IF (IV(CNVCOD) .NE. 0) GO TO 700
      IF (IV(MODE) .EQ. 0) GO TO 570
      IV(MODE) = 0
C
C
C-----------------------------  MAIN LOOP  -----------------------------
C
C
C  ***  PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT  ***
C
 150  CALL ITSMRY(D, IV, P, V, X)
 160  K = IV(NITER)
      IF (K .LT. IV(MXITER)) GO TO 170
         IV(1) = 10
         GO TO 900
 170  IV(NITER) = K + 1
C
C  ***  UPDATE RADIUS  ***
C
      IF (K .EQ. 0) GO TO 185
      STEP1 = IV(STEP)
      DO 180 I = 1, P
         V(STEP1) = D(I) * V(STEP1)
         STEP1 = STEP1 + 1
 180     CONTINUE
      STEP1 = IV(STEP)
      V(RADIUS) = V(RADFAC) * V2NORM(P, V(STEP1))
C
C  ***  INITIALIZE FOR START OF NEXT ITERATION  ***
C
 185  X01 = IV(X0)
      V(F0) = V(F)
      IV(KAGQT) = -1
      IV(IRC) = 4
      IV(H) = -IABS(IV(H))
      IV(SUSED) = IV(MODEL)
C
C     ***  COPY X TO X0  ***
C
      CALL VCOPY(P, V(X01), X)
C
C  ***  CHECK STOPX AND FUNCTION EVALUATION LIMIT  ***
C
 190  IF (.NOT. STOPX(DUMMY)) GO TO 200
         IV(1) = 11
         GO TO 205
C
C     ***  COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
C
 195  IF (V(F) .GE. V(F0)) GO TO 200
         V(RADFAC) = ONE
         K = IV(NITER)
         GO TO 170
C
 200  IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 210
         IV(1) = 9
 205     IF (V(F) .GE. V(F0)) GO TO 900
C
C        ***  IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
C        ***  IMPROVED V(F), EVALUATE THE GRADIENT AT X.
C
              IV(CNVCOD) = IV(1)
              GO TO 560
C
C. . . . . . . . . . . . .  COMPUTE CANDIDATE STEP  . . . . . . . . . .
C
 210  STEP1 = IV(STEP)
      W1 = IV(W)
      IF (IV(MODEL) .EQ. 2) GO TO 240
C
C  ***  COMPUTE LEVENBERG-MARQUARDT STEP  ***
C
         QTR1 = IV(QTR)
         IF (IV(KALM) .GE. 0) GO TO 215
              RD1 = IV(RD)
              IF (-1 .EQ. IV(KALM)) CALL QRFACT(NN, N, P, J, V(RD1),
     1                                   IV(IPIVOT), IV(IERR), 0, V(W1))
              CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR))
 215     H1 = IV(H)
         IF (H1 .GT. 0) GO TO 230
C
C        ***  COPY R MATRIX TO H  ***
C
              H1 = -H1
              IV(H) = H1
              K = H1
              RD1 = IV(RD)
              V(K) = V(RD1)
              IF (P .EQ. 1) GO TO 230
              DO 220 I = 2, P
                   CALL VCOPY(I-1, V(K+1), J(1,I))
                   K = K + I
                   RD1 = RD1 + 1
                   V(K) = V(RD1)
 220               CONTINUE
C
 230     G1 = IV(G)
         CALL LMSTEP(D, V(G1), IV(IERR), IV(IPIVOT), IV(KALM), P,
     1               V(QTR1), V(H1), V(STEP1), V, V(W1))
         GO TO 310
C
C  ***  COMPUTE GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL)  ***
C
 240  IF (IV(H) .GT. 0) GO TO 300
C
C     ***  SET H TO  D**-1 * ( (J**T)*J + S) ) * D**-1.  ***
C
         H1 = -IV(H)
         IV(H) = H1
         S1 = IV(S)
         IF (-1 .NE. IV(KALM)) GO TO 270
C
C        ***  J IS IN ITS ORIGINAL FORM  ***
C
              DO 260 I = 1, P
                   T = ONE / D(I)
                   DO 250 K = 1, I
                        V(H1) = T*(DOTPRD(N,J(1,I),J(1,K))+V(S1)) / D(K)
                        H1 = H1 + 1
                        S1 = S1 + 1
 250                    CONTINUE
 260               CONTINUE
              GO TO 300
C
C  ***  LMSTEP HAS APPLIED QRFACT TO J  ***
C
 270     SMH = S1 - H1
         H0 = H1 - 1
         IPIV1 = IV(IPIVOT)
         T1 = ONE / D(IPIV1)
         RD0 = IV(RD) - 1
         RDOF1 = V(RD0 + 1)
         DO 290 I = 1, P
              L = IPIV0 + I
              IPIVI = IV(L)
              H1 = H0 + IPIVI*(IPIVI-1)/2
              L = H1 + IPIVI
              M = L + SMH
C             ***  V(L) = H(IPIVOT(I), IPIVOT(I))  ***
C             ***  V(M) = S(IPIVOT(I), IPIVOT(I))  ***
              T = ONE / D(IPIVI)
              RDK = RD0 + I
              E = V(RDK)**2
              IF (I .GT. 1) E = E + DOTPRD(I-1, J(1,I), J(1,I))
              V(L) = (E + V(M)) * T**2
              IF (I .EQ. 1) GO TO 290
              L = H1 + IPIV1
              IF (IPIVI .LT. IPIV1) L = L +
     1                               ((IPIV1-IPIVI)*(IPIV1+IPIVI-3))/2
              M = L + SMH
C             ***  V(L) = H(IPIVOT(I), IPIVOT(1))  ***
C             ***  V(M) = S(IPIVOT(I), IPIVOT(1))  ***
              V(L) = T * (RDOF1 * J(1,I)  +  V(M)) * T1
              IF (I .EQ. 2) GO TO 290
              IM1 = I - 1
              DO 280 K = 2, IM1
                   IPK = IPIV0 + K
                   IPIVK = IV(IPK)
                   L = H1 + IPIVK
                   IF (IPIVI .LT. IPIVK) L = L +
     1                               ((IPIVK-IPIVI)*(IPIVK+IPIVI-3))/2
                   M = L + SMH
C                  ***  V(L) = H(IPIVOT(I), IPIVOT(K))  ***
C                  ***  V(M) = S(IPIVOT(I), IPIVOT(K))  ***
                   KM1 = K - 1
                   RDK = RD0 + K
                   V(L) = T * (DOTPRD(KM1, J(1,I), J(1,K)) +
     1                            V(RDK)*J(K,I) + V(M)) / D(IPIVK)
 280               CONTINUE
 290          CONTINUE
C
C  ***  COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP  ***
C
 300  H1 = IV(H)
      DIG1 = IV(DIG)
      LMAT1 = IV(LMAT)
      CALL GQTSTP(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1),
     1            V, V(W1))
C
C
C  ***  COMPUTE R(X0 + STEP)  ***
C
 310  IF (IV(IRC) .EQ. 6) GO TO 350
      X01 = IV(X0)
      STEP1 = IV(STEP)
      CALL VAXPY(P, X, ONE, V(STEP1), V(X01))
      IV(NFCALL) = IV(NFCALL) + 1
      IV(1) = 1
      IV(TOOBIG) = 0
      GO TO 999
C
C. . . . . . . . . . . . .  ASSESS CANDIDATE STEP  . . . . . . . . . . .
C
 350  STEP1 = IV(STEP)
      LSTGST = IV(STLSTG)
      X01 = IV(X0)
      CALL ASSESS(D, IV, P, V(STEP1), V(LSTGST), V, X, V(X01))
C
C  ***  IF NECESSARY, SWITCH MODELS AND/OR RESTORE R  ***
C
      IF (IV(SWITCH) .EQ. 0) GO TO 360
         IV(H) = -IABS(IV(H))
         IV(SUSED) = IV(SUSED) + 2
         CALL VCOPY(NVSAVE, V, V(VSAVE1))
 360  IF (IV(RESTOR) .EQ. 0) GO TO 390
         RSAVE1 = IV(RSAVE)
         CALL VCOPY(N, R, V(RSAVE1))
 390  L = IV(IRC) - 4
      STPMOD = IV(MODEL)
      IF (L .GT. 0) GO TO (410,440,450,450,450,450,450,450,640,570), L
C
C  ***  DECIDE WHETHER TO CHANGE MODELS  ***
C
      E = V(PREDUC) - V(FDIF)
      SSTEP = IV(LKY)
      S1 = IV(S)
      CALL SLVMUL(P, V(SSTEP), V(S1), V(STEP1))
      STTSST = HALF * DOTPRD(P, V(STEP1), V(SSTEP))
      IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
      IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 400
C
C     ***  SWITCH MODELS  ***
C
         IV(MODEL) = 3 - IV(MODEL)
         IF (IV(MODEL) .EQ. 1) IV(KAGQT) = -1
         IF (IV(MODEL) .EQ. 2 .AND. IV(KALM) .GT. 0) IV(KALM) = 0
         IF (-2 .LT. L) GO TO 480
              IV(H) = -IABS(IV(H))
              IV(SUSED) = IV(SUSED) + 2
              CALL VCOPY(NVSAVE, V(VSAVE1), V)
              GO TO 420
C
 400  IF (-3 .LT. L) GO TO 480
C
C     ***  RECOMPUTE STEP WITH DECREASED RADIUS  ***
C
         V(RADIUS) = V(RADFAC) * V(DSTNRM)
         GO TO 190
C
C  ***  RECOMPUTE STEP, SAVING V VALUES AND R IF NECESSARY  ***
C
 410  V(RADIUS) = V(RADFAC) * V(DSTNRM)
 420  IF (V(F) .GE. V(F0)) GO TO 190
      RSAVE1 = IV(RSAVE)
      CALL VCOPY(N, V(RSAVE1), R)
      GO TO 190
C
C  ***  COMPUTE STEP OF LENGTH V(LMAX0) FOR SINGULAR CONVERGENCE TEST
C
 440  V(RADIUS) = V(LMAX0)
      GO TO 210
C
C  ***  CONVERGENCE OR FALSE CONVERGENCE  ***
C
 450  IV(CNVCOD) = L
      IF (V(F) .GE. V(F0)) GO TO 700
         IF (IV(XIRC) .EQ. 14) GO TO 700
              IV(XIRC) = 14
C
C. . . . . . . . . . . .  PROCESS ACCEPTABLE STEP  . . . . . . . . . . .
C
 480  IV(COVMAT) = 0
C
C  ***  SET  LKY = (J(X0)**T) * R(X)  ***
C
      LKY1 = IV(LKY)
      IF (IV(KALM) .GE. 0) GO TO 500
C
C     ***  JACOBIAN HAS NOT BEEN MODIFIED  ***
C
         DO 490 I = 1, P
              V(LKY1) = DOTPRD(N, J(1,I), R)
              LKY1 = LKY1 + 1
 490          CONTINUE
         GO TO 510
C
C  ***  QRFACT HAS BEEN APPLIED TO J.  STORE COPY OF R IN QTR AND  ***
C  ***  APPLY Q TO IT.                                             ***
C
 500  QTR1 = IV(QTR)
      CALL VCOPY(N, V(QTR1), R)
      CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR))
C
C  ***  MULTIPLY TOP P-VECTOR IN QTR BY PERMUTED UPPER TRIANGLE    ***
C  ***  STORED BY QRFACT IN J AND RD.                              ***
C
      RD1 = IV(RD)
      TEMP1 = IV(STLSTG)
      CALL RPTMUL(3, IV(IPIVOT), J, NN, P, V(RD1), V(QTR1), V(LKY1),
     1            V(TEMP1))
C
C  ***  SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS  ***
C
 510  IF (IV(IRC) .NE. 3) GO TO 560
         STEP1 = IV(STEP)
         TEMP1 = IV(STLSTG)
         TEMP2 = IV(X0)
C
C     ***  SET  TEMP1 = HESSIAN * STEP  FOR USE IN GRADIENT TESTS  ***
C
         IF (STPMOD .EQ. 2) GO TO 530
C
C        ***  STEP COMPUTED USING GAUSS-NEWTON MODEL  ***
C        ***  -- QRFACT HAS BEEN APPLIED TO J         ***
C
              RD1 = IV(RD)
              CALL RPTMUL(2, IV(IPIVOT), J, NN, P, V(RD1),
     1                    V(STEP1), V(TEMP1), V(TEMP2))
              GO TO 560
C
C     ***  STEP COMPUTED USING AUGMENTED MODEL  ***
C
 530     H1 = IV(H)
         K = TEMP2
         DO 540 I = 1, P
              V(K) = D(I) * V(STEP1)
              K = K + 1
              STEP1 = STEP1 + 1
 540          CONTINUE
         CALL SLVMUL(P, V(TEMP1), V(H1), V(TEMP2))
         DO 550 I = 1, P
              V(TEMP1) = D(I) * V(TEMP1)
              TEMP1 = TEMP1 + 1
 550          CONTINUE
C
C  ***  SAVE OLD GRADIENT AND COMPUTE NEW ONE  ***
C
 560  IV(NGCALL) = IV(NGCALL) + 1
      G1 = IV(G)
      G01 = IV(W)
      CALL VCOPY(P, V(G01), V(G1))
      IV(1) = 2
      GO TO 999
C
C  ***  INITIALIZATIONS -- G0 = G - G0, ETC.  ***
C
 570  G01 = IV(W)
      G1 = IV(G)
      CALL VAXPY(P, V(G01), NEGONE, V(G01), V(G1))
      STEP1 = IV(STEP)
      TEMP1 = IV(STLSTG)
      TEMP2 = IV(X0)
      IF (IV(IRC) .NE. 3) GO TO 600
C
C  ***  SET V(RADFAC) BY GRADIENT TESTS  ***
C
C     ***  SET  TEMP1 = D**-1 * (HESSIAN * STEP  +  (G(X0) - G(X)))  ***
C
         K = TEMP1
         L = G01
         DO 580 I = 1, P
              V(K) = (V(K) - V(L)) / D(I)
              K = K + 1
              L = L + 1
 580          CONTINUE
C
C        ***  DO GRADIENT TESTS  ***
C
         IF (V2NORM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))  GO TO 590
              IF (DOTPRD(P, V(G1), V(STEP1))
     1                  .GE. V(GTSTEP) * V(TUNER5))  GO TO 600
 590               V(RADFAC) = V(INCFAC)
C
C  ***  FINISH COMPUTING LKY = ((J(X) - J(X0))**T) * R  ***
C
C     ***  CURRENTLY LKY = (J(X0)**T) * R  ***
C
 600  LKY1 = IV(LKY)
      CALL VAXPY(P, V(LKY1), NEGONE, V(LKY1), V(G1))
C
C  ***  DETERMINE SIZING FACTOR V(SIZE)  ***
C
C     ***  SET TEMP1 = S * STEP  ***
      S1 = IV(S)
      CALL SLVMUL(P, V(TEMP1), V(S1), V(STEP1))
C
      T1 = DABS(DOTPRD(P, V(STEP1), V(TEMP1)))
      T = DABS(DOTPRD(P, V(STEP1), V(LKY1)))
      V(SIZE) = ONE
      IF (T .LT. T1) V(SIZE) = T / T1
C
C  ***  UPDATE S  ***
C
      CALL SLUPDT(V(S1), V(COSMIN), P, V(SIZE), V(STEP1), V(TEMP1),
     1            V(TEMP2), V(G01), V(WSCALE), V(LKY1))
      IV(1) = 2
      GO TO 150
C
C. . . . . . . . . . . . . .  MISC. DETAILS  . . . . . . . . . . . . . .
C
C  ***  BAD PARAMETERS TO ASSESS  ***
C
 640  IV(1) = 14
      GO TO 900
C
C  ***  CONVERGENCE OBTAINED -- COMPUTE COVARIANCE MATRIX IF DESIRED ***
C
 700  IF (IV(COVREQ) .EQ. 0 .AND. IV(COVPRT) .EQ. 0) GO TO 760
      IF (IV(COVMAT) .NE. 0) GO TO 760
      IF (IV(CNVCOD) .GE. 7) GO TO 760
      IV(MODE) = 0
 710  CALL COVCLC(I, D, IV, J, N, NN, P, R, V, X)
      GO TO (720, 720, 740, 750), I
 720  IV(NFCOV) = IV(NFCOV) + 1
      IV(NFCALL) = IV(NFCALL) + 1
      IV(RESTOR) = I
      IV(1) = 1
      GO TO 999
C
 730  IF (IV(RESTOR) .EQ. 1 .OR. IV(TOOBIG) .NE. 0) GO TO 710
      IV(NFGCAL) = IV(NFCALL)
 740  IV(NGCOV) = IV(NGCOV) + 1
      IV(NGCALL) = IV(NGCALL) + 1
      IV(1) = 2
      GO TO 999
C
 750  IV(MODE) = 0
      IF (IV(NITER) .EQ. 0) IV(MODE) = -1
C
 760  IV(1) = IV(CNVCOD)
      IV(CNVCOD) = 0
C
C  ***  PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS  ***
C
 900  CALL ITSMRY(D, IV, P, V, X)
C
 999  RETURN
C
C  ***  LAST CARD OF NL2ITR FOLLOWS  ***
      END
      SUBROUTINE ASSESS (D, IV, P, STEP, STLSTG, V, X, X0)              ASS00010
C
C  ***  ASSESS CANDIDATE STEP (NL2SOL VERSION 2.2)  ***
C
      INTEGER P, IV(13)
      DOUBLE PRECISION D(P), STEP(P), STLSTG(P), V(35), X(P), X0(P)
C
C  ***  PURPOSE  ***
C
C        THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
C     ROUTINE TO ASSESS THE NEXT CANDIDATE STEP.  IT MAY RECOMMEND ONE
C     OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
C     PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
C     TO CONVERGENCE OR FALSE CONVERGENCE.  SEE THE RETURN CODE LISTING
C     BELOW.
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C     IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF IV VALUES REFERENCED.
C      D (IN)  SCALE VECTOR USED IN COMPUTING V(RELDX) -- SEE BELOW.
C      P (IN)  NUMBER OF PARAMETERS BEING OPTIMIZED.
C   STEP (I/O) ON INPUT, STEP IS THE STEP TO BE ASSESSED.  IT IS UN-
C             CHANGED ON OUTPUT UNLESS A PREVIOUS STEP ACHIEVED A
C             BETTER OBJECTIVE FUNCTION REDUCTION, IN WHICH CASE STLSTG
C             WILL HAVE BEEN COPIED TO STEP.
C STLSTG (I/O) WHEN ASSESS RECOMMENDS RECOMPUTING STEP EVEN THOUGH THE
C             CURRENT (OR A PREVIOUS) STEP YIELDS AN OBJECTIVE FUNC-
C             TION DECREASE, IT SAVES IN STLSTG THE STEP THAT GAVE THE
C             BEST FUNCTION REDUCTION SEEN SO FAR (IN THE CURRENT ITERA-
C             TION).  IF THE RECOMPUTED STEP YIELDS A LARGER FUNCTION
C             VALUE, THEN STEP IS RESTORED FROM STLSTG AND
C             X = X0 + STEP IS RECOMPUTED.
C      V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF V VALUES REFERENCED.
C      X (I/O) ON INPUT, X = X0 + STEP IS THE POINT AT WHICH THE OBJEC-
C             TIVE FUNCTION HAS JUST BEEN EVALUATED.  IF AN EARLIER
C             STEP YIELDED A BIGGER FUNCTION DECREASE, THEN X IS
C             RESTORED TO THE CORRESPONDING EARLIER VALUE.  OTHERWISE,
C             IF THE CURRENT STEP DOES NOT GIVE ANY FUNCTION DECREASE,
C             THEN X IS RESTORED TO X0.
C     X0 (IN)  INITIAL OBJECTIVE FUNCTION PARAMETER VECTOR (AT THE
C             START OF THE CURRENT ITERATION).
C
C  ***  IV VALUES REFERENCED  ***
C
C    IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
C             IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
C             SET WHEN STEP IS DEFINITELY TO BE ACCEPTED).  ON INPUT
C             AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
C             UNCHANGED SINCE THE PREVIOUS RETURN OF ASSESS.
C                ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
C             FOLLOWING VALUES...
C                  1 = SWITCH MODELS OR TRY SMALLER STEP.
C                  2 = SWITCH MODELS OR ACCEPT STEP.
C                  3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
C                       TESTS.
C                  4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
C                  5 = RECOMPUTE STEP (USING THE SAME MODEL).
C                  6 = RECOMPUTE STEP WITH RADIUS = V(LMAX0) BUT DO NOT
C                       EVAULATE THE OBJECTIVE FUNCTION.
C                  7 = X-CONVERGENCE (SEE V(XCTOL)).
C                  8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
C                  9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
C                 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
C                 11 = SINGULAR CONVERGENCE (SEE V(LMAX0)).
C                 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
C                 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
C             RETURN CODE I HAS PRECDENCE OVER I+1 FOR I = 9, 10, 11.
C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
C  IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
C             THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
C             IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
C             THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
C IV(NFCALL) (IN)  INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
C             FUNCTION REDUCTION THIS ITERATION.  IV(NFGCAL) REMAINS
C             UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
C             OF DECREASES) SO FAR THIS ITERATION.
C IV(RESTOR) (OUT) SET TO 0 UNLESS X AND V(F) HAVE BEEN RESTORED, IN
C             WHICH CASE ASSESS SETS IV(RESTOR) = 1.
C  IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
C             CURRENT ITERATION.
C IV(STGLIM) (IN)  MAXIMUM NUMBER OF MODELS TO CONSIDER.
C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
C             GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
C             IN WHICH CASE ASSESS SETS IV(SWITCH) = 1.
C IV(TOOBIG) (IN)  IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED
C             OVERFLOW).
C   IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
C             CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
C
C  ***  V VALUES REFERENCED  ***
C
C V(AFCTOL) (IN)  ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
C             THAN V(AFCTOL), THEN ASSESS RETURNS WITH IV(IRC) = 10.
C V(DECFAC) (IN)  FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
C             NONZERO.
C V(DSTNRM) (IN)  THE 2-NORM OF D*STEP.
C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
C   V(DST0) (IN)  THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
C             I.E., FOR V(NREDUC) .GE. 0).
C      V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
C             TION VALUE AT X.  IF X IS RESTORED TO A PREVIOUS VALUE,
C             THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
C   V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
C             VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
C             DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
C     V(F0) (IN)  OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
C V(GTSTEP) (IN)  INNER PRODUCT BETWEEN STEP AND GRADIENT.
C V(INCFAC) (IN)  MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
C  V(LMAX0) (IN)  MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
C             IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
C             WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, 9,
C             OR 10 DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAX0), AND IF
C             V(PREDUC) .LE. V(RFCTOL) * ABS(V(F0)), THEN ASSESS RE-
C             TURNS WITH IV(IRC) = 11.  IF SO DOING APPEARS WORTHWHILE,
C             THEN ASSESS REPEATS THIS TEST WITH V(PREDUC) COMPUTED FOR
C             A STEP OF LENGTH V(LMAX0) (BY A RETURN WITH IV(IRC) = 6).
C V(NREDUC) (I/O)  FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             NEWTON STEP.  IF ASSESS IS CALLED WITH IV(IRC) = 6, I.E.,
C             IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAX0) FOR
C             USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS
C             SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             CURRENT STEP.
C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
C             WHICH SHOULD BE V(RADFAC)*DST, WHERE  DST  IS EITHER THE
C             OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
C             DIAG(NEWD)*STEP  FOR THE OUTPUT VALUE OF STEP AND THE
C             UPDATED VERSION, NEWD, OF THE SCALE VECTOR D.  FOR
C             IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
C V(RDFCMN) (IN)  MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
C             VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
C V(RDFCMX) (IN)  MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
C  V(RELDX) (OUT) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
C             BY FUNCTION  RELDST  AS
C                 MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
C                    MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
C             IF AN ACCEPTABLE STEP IS RETURNED, THEN V(RELDX) IS COM-
C             PUTED USING THE OUTPUT (POSSIBLY RESTORED) VALUES OF X
C             AND STEP.  OTHERWISE IT IS COMPUTED USING THE INPUT
C             VALUES.
C V(RFCTOL) (IN)  RELATIVE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
C             DICTED AND  V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)),  THEN
C             ASSESS RETURNS WITH IV(IRC) = 8 OR 9.  SEE ALSO V(LMAX0).
C V(STPPAR) (IN)  MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
C V(TUNER1) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS MUCH LESS THAN EXPECTED.  SUGGESTED
C             VALUE = 0.1.
C V(TUNER2) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP.  SUGGESTED
C             VALUE = 10**-4.
C V(TUNER3) (IN)  TUNING CONSTANT USED TO DECIDE IF THE RADIUS
C             SHOULD BE INCREASED.  SUGGESTED VALUE = 0.75.
C  V(XCTOL) (IN)  X-CONVERGENCE CRITERION.  IF STEP IS A NEWTON STEP
C             (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
C             AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
C             ASSESS RETURNS IV(IRC) = 7 OR 9.
C  V(XFTOL) (IN)  FALSE CONVERGENCE TOLERANCE.  IF STEP GAVE NO OR ONLY
C             A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
C             THEN ASSESS RETURNS WITH IV(IRC) = 12.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C        THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
C     LEAST-SQUARES) PACKAGE.  IT MAY BE USED IN ANY UNCONSTRAINED
C     MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
C     OR LEVENBERG-MARQUARDT STEPS.
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
C     SWITCHING STRATEGIES.  WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
C     ASSESS IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
C
C  ***  USAGE NOTES  ***
C
C        ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
C     STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
C     V(PREDUC) NEED HAVE BEEN INITIALIZED.  BETWEEN CALLS, NO I/O
C     VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
C     ANCES SHOULD BE CHANGED.
C        AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
C     CHANGE THE STOPPING TOLERANCES AND CALL ASSESS AGAIN, IN WHICH
C     CASE THE STOPPING TESTS WILL BE REPEATED.
C
C  ***  REFERENCES  ***
C
C     (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981),
C        AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
C        ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3.
C
C     (2) POWELL, M.J.D. (1970)  A FORTRAN SUBROUTINE FOR SOLVING
C        SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
C        METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
C        P. RABINOWITZ, GORDON AND BREACH, LONDON.
C
C  ***  HISTORY  ***
C
C        JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
C     IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
C        DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
C     PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
C     PRESENT FORM (FALL 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C------------------------  EXTERNAL QUANTITIES  ------------------------
C
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL RELDST, VCOPY
      DOUBLE PRECISION RELDST
C
C VCOPY.... COPIES ONE VECTOR TO ANOTHER.
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      DOUBLE PRECISION DABS, DMAX1
C/
C  ***  NO COMMON BLOCKS  ***
C
C--------------------------  LOCAL VARIABLES  --------------------------
C
      LOGICAL GOODX
      INTEGER I, NFC
      DOUBLE PRECISION EMAX, GTS, HALF, ONE, RELDX1, RFAC1, TWO, XMAX,
     1                 ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
     1        GTSLST, GTSTEP, INCFAC, IRC, LMAX0, MLSTGD, MODEL, NFCALL,
     2        NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
     3        RDFCMX, RELDX, RESTOR, RFCTOL, STAGE, STGLIM, STPPAR,
     4        SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, XFTOL,
     5        XIRC
C
C  ***  DATA INITIALIZATIONS  ***
C
C/6
      DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0)
C/
C
C/6
      DATA IRC/3/, MLSTGD/4/, MODEL/5/, NFCALL/6/,
     1     NFGCAL/7/, RADINC/8/, RESTOR/9/, STAGE/10/,
     2     STGLIM/11/, SWITCH/12/, TOOBIG/2/, XIRC/13/
C/7
C     PARAMETER (IRC=3, MLSTGD=4, MODEL=5, NFCALL=6,
C    1     NFGCAL=7, RADINC=8, RESTOR=9, STAGE=10,
C    2     STGLIM=11, SWITCH=12, TOOBIG=2, XIRC=13)
C/
C/6
      DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/,
     1     DSTSAV/18/, F/10/, FDIF/11/, FLSTGD/12/, F0/13/,
     2     GTSLST/14/, GTSTEP/4/, INCFAC/23/,
     3     LMAX0/35/, NREDUC/6/, PLSTGD/15/, PREDUC/7/,
     4     RADFAC/16/, RDFCMN/24/, RDFCMX/25/,
     5     RELDX/17/, RFCTOL/32/, STPPAR/5/, TUNER1/26/,
     6     TUNER2/27/, TUNER3/28/, XCTOL/33/, XFTOL/34/
C/7
C     PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3,
C    1     DSTSAV=18, F=10, FDIF=11, FLSTGD=12, F0=13,
C    2     GTSLST=14, GTSTEP=4, INCFAC=23,
C    3     LMAX0=35, NREDUC=6, PLSTGD=15, PREDUC=7,
C    4     RADFAC=16, RDFCMN=24, RDFCMX=25,
C    5     RELDX=17, RFCTOL=32, STPPAR=5, TUNER1=26,
C    6     TUNER2=27, TUNER3=28, XCTOL=33, XFTOL=34)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      NFC = IV(NFCALL)
      IV(SWITCH) = 0
      IV(RESTOR) = 0
      RFAC1 = ONE
      GOODX = .TRUE.
      I = IV(IRC)
      IF (I .GE. 1 .AND. I .LE. 12)
     1             GO TO (20,30,10,10,40,360,290,290,290,290,290,140), I
         IV(IRC) = 13
         GO TO 999
C
C  ***  INITIALIZE FOR NEW ITERATION  ***
C
 10   IV(STAGE) = 1
      IV(RADINC) = 0
      V(FLSTGD) = V(F0)
      IF (IV(TOOBIG) .EQ. 0) GO TO 90
         IV(STAGE) = -1
         IV(XIRC) = I
         GO TO 60
C
C  ***  STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS  ***
C  ***  FIRST DECIDE WHICH  ***
C
 20   IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
C        ***  OLD MODEL RETAINED, SMALLER RADIUS TRIED  ***
C        ***  DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION  ***
         IV(STAGE) = IV(STGLIM)
         IV(RADINC) = -1
         GO TO 90
C
C  ***  A NEW MODEL IS BEING TRIED.  DECIDE WHETHER TO KEEP IT.  ***
C
 30   IV(STAGE) = IV(STAGE) + 1
C
C     ***  NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH  ***
C     ***  THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP.     ***
C
 40   IF (IV(STAGE) .GT. 0) GO TO 50
C
C        ***  STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG.  ***
C
         IF (IV(TOOBIG) .NE. 0) GO TO 60
C
C        ***  RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF.  ***
C
         IV(STAGE) = -IV(STAGE)
         I = IV(XIRC)
         GO TO (20, 30, 90, 90, 70), I
C
 50   IF (IV(TOOBIG) .EQ. 0) GO TO 70
C
C  ***  HANDLE OVERSIZE STEP  ***
C
      IF (IV(RADINC) .GT. 0) GO TO 80
         IV(STAGE) = -IV(STAGE)
         IV(XIRC) = IV(IRC)
C
 60      V(RADFAC) = V(DECFAC)
         IV(RADINC) = IV(RADINC) - 1
         IV(IRC) = 5
         GO TO 999
C
 70   IF (V(F) .LT. V(FLSTGD)) GO TO 90
C
C     *** THE NEW STEP IS A LOSER.  RESTORE OLD MODEL.  ***
C
      IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
         IV(MODEL) = IV(MLSTGD)
         IV(SWITCH) = 1
C
C     ***  RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
C
 80   IF (V(FLSTGD) .GE. V(F0)) GO TO 90
         IV(RESTOR) = 1
         V(F) = V(FLSTGD)
         V(PREDUC) = V(PLSTGD)
         V(GTSTEP) = V(GTSLST)
         IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
         V(DSTNRM) = V(DSTSAV)
         NFC = IV(NFGCAL)
         GOODX = .FALSE.
C
C
C  ***  COMPUTE RELATIVE CHANGE IN X BY CURRENT STEP  ***
C
 90   RELDX1 = RELDST(P, D, X, X0)
C
C  ***  RESTORE X AND STEP IF NECESSARY  ***
C
      IF (GOODX) GO TO 105
      DO 100 I = 1, P
         STEP(I) = STLSTG(I)
         X(I) = X0(I) + STLSTG(I)
 100     CONTINUE
C
 105  V(FDIF) = V(F0) - V(F)
      IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 120
C
C        ***  NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
C        ***  -- SO TRY NEW MODEL OR SMALLER RADIUS
C
         V(RELDX) = RELDX1
         IF (V(F) .LT. V(F0)) GO TO 110
              IV(MLSTGD) = IV(MODEL)
              V(FLSTGD) = V(F)
              V(F) = V(F0)
              CALL VCOPY(P, X, X0)
              IV(RESTOR) = 1
              GO TO 115
 110     IV(NFGCAL) = NFC
 115     IV(IRC) = 1
         IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 130
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) - 1
              GO TO 130
C
C  ***  NONTRIVIAL FUNCTION DECREASE ACHIEVED  ***
C
 120  IV(NFGCAL) = NFC
      RFAC1 = ONE
      IF (GOODX) V(RELDX) = RELDX1
      V(DSTSAV) = V(DSTNRM)
      IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 200
C
C  ***  DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
C  ***  OR ACCEPT STEP WITH DECREASED RADIUS.
C
      IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 125
C        ***  CONSIDER SWITCHING MODELS  ***
         IV(IRC) = 2
         GO TO 130
C
C     ***  ACCEPT STEP WITH DECREASED RADIUS  ***
C
 125  IV(IRC) = 4
C
C  ***  SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR  ***
C
 130  IV(XIRC) = IV(IRC)
      EMAX = V(GTSTEP) + V(FDIF)
      V(RADFAC) = HALF * RFAC1
      IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * DMAX1(V(RDFCMN),
     1                                           HALF * V(GTSTEP)/EMAX)
C
C  ***  DO FALSE CONVERGENCE TEST  ***
C
 140  IF (V(RELDX) .LE. V(XFTOL)) GO TO 160
         IV(IRC) = IV(XIRC)
         IF (V(F) .LT. V(F0)) GO TO 230
              GO TO 300
C
 160  IV(IRC) = 12
      GO TO 310
C
C  ***  HANDLE GOOD FUNCTION DECREASE  ***
C
 200  IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 260
C
C     ***  INCREASING RADIUS LOOKS WORTHWHILE.  SEE IF WE JUST
C     ***  RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
C     ***  AFTER RECOMPUTING IT WITH A LARGER RADIUS.
C
      IF (IV(RADINC) .LT. 0) GO TO 260
      IF (IV(RESTOR) .EQ. 1) GO TO 260
C
C        ***  WE DID NOT.  TRY A LONGER STEP UNLESS THIS WAS A NEWTON
C        ***  STEP.
C
         V(RADFAC) = V(RDFCMX)
         GTS = V(GTSTEP)
         IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
     1            V(RADFAC) = DMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
         IV(IRC) = 4
         IF (V(STPPAR) .EQ. ZERO) GO TO 300
C             ***  STEP WAS NOT A NEWTON STEP.  RECOMPUTE IT WITH
C             ***  A LARGER RADIUS.
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) + 1
C
C  ***  SAVE VALUES CORRESPONDING TO GOOD STEP  ***
C
 230  V(FLSTGD) = V(F)
      IV(MLSTGD) = IV(MODEL)
      CALL VCOPY(P, STLSTG, STEP)
      V(DSTSAV) = V(DSTNRM)
      IV(NFGCAL) = NFC
      V(PLSTGD) = V(PREDUC)
      V(GTSLST) = V(GTSTEP)
      GO TO 300
C
C  ***  ACCEPT STEP WITH RADIUS UNCHANGED  ***
C
 260  V(RADFAC) = ONE
      IV(IRC) = 3
      GO TO 300
C
C  ***  COME HERE FOR A RESTART AFTER CONVERGENCE  ***
C
 290  IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .GE. ZERO) GO TO 310
         IV(IRC) = 12
         GO TO 310
C
C  ***  PERFORM CONVERGENCE TESTS  ***
C
 300  IV(XIRC) = IV(IRC)
 310  IF (DABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
      IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
      EMAX = V(RFCTOL) * DABS(V(F0))
      IF (V(DSTNRM) .GT. V(LMAX0) .AND. V(PREDUC) .LE. EMAX)
     1                       IV(IRC) = 11
      IF (V(DST0) .LT. ZERO) GO TO 320
      I = 0
      IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
     1    (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO))  I = 2
      IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)
     1                        .AND. GOODX)                  I = I + 1
      IF (I .GT. 0) IV(IRC) = I + 6
C
C  ***  CONSIDER RECOMPUTING STEP OF LENGTH V(LMAX0) FOR SINGULAR
C  ***  CONVERGENCE TEST.
C
 320  IF (IABS(IV(IRC)-3) .GT. 2 .AND. IV(IRC) .NE. 12) GO TO 999
      IF (V(DSTNRM) .GT. V(LMAX0)) GO TO 330
         IF (V(PREDUC) .GE. EMAX) GO TO 999
              IF (V(DST0) .LE. ZERO) GO TO 340
                   IF (HALF * V(DST0) .LE. V(LMAX0)) GO TO 999
                        GO TO 340
 330  IF (HALF * V(DSTNRM) .LE. V(LMAX0)) GO TO 999
      XMAX = V(LMAX0) / V(DSTNRM)
      IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAX) GO TO 999
 340  IF (V(NREDUC) .LT. ZERO) GO TO 370
C
C  ***  RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST  ***
C
      V(GTSLST) = V(GTSTEP)
      V(DSTSAV) = V(DSTNRM)
      IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
      V(PLSTGD) = V(PREDUC)
      IV(IRC) = 6
      CALL VCOPY(P, STLSTG, STEP)
      GO TO 999
C
C  ***  PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC)  ***
C
 360  V(GTSTEP) = V(GTSLST)
      V(DSTNRM) = DABS(V(DSTSAV))
      CALL VCOPY(P, STEP, STLSTG)
      IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
      V(NREDUC) = -V(PREDUC)
      V(PREDUC) = V(PLSTGD)
 370  IF (-V(NREDUC) .LE. V(RFCTOL) * DABS(V(F0))) IV(IRC) = 11
C
 999  RETURN
C
C  ***  LAST CARD OF ASSESS FOLLOWS  ***
      END
      SUBROUTINE COVCLC(COVIRC, D, IV, J, N, NN, P, R, V, X)            COV00010
C
C  ***  COMPUTE COVARIANCE MATRIX FOR NL2ITR (NL2SOL VERSION 2.2)  ***
C
C  ***  LET K = IABS(IV(COVREQ).  FOR K .LE. 2, A FINITE-DIFFERENCE
C  ***  HESSIAN H IS COMPUTED (USING FUNC. AND GRAD. VALUES IF
C  ***  IV(COVREQ) IS NONNEGATIVE, AND USING ONLY FUNC. VALUES IF
C  ***  IV(COVREQ) IS NEGATIVE).  FOR SCALE = 2*F(X) / MAX(1, N-P),
C  ***  WHERE 2*F(X) IS THE RESIDUAL SUM OF SQUARES, COVCLC COMPUTES...
C  ***             K = 0 OR 1...  SCALE * H**-1 * (J**T * J) * H**-1.
C  ***             K = 2...  SCALE * H**-1.
C  ***             K .GE. 3...  SCALE * (J**T * J)**-1.
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER COVIRC, IV(1), N, NN, P
      DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
      LOGICAL HAVEJ
      INTEGER COV, GP, GSAVE1, G1, HC, HMI, HPI, HPM, I, IPIVI, IPIVK,
     1        IP1, IRC, K, KIND, KL, L, M, MM1, MM1O2, PP1O2, QTR1,
     2        RD1, STPI, STPM, STP0, WL, W0, W1
      DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS, MAX0
      REAL FLOAT
      DOUBLE PRECISION DABS, DMAX1
C/
C  ***  EXTERNAL SUBROUTINES  ***
C
      EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRT, LTSQAR, QRFACT,
     1         VCOPY, VSCOPY
C
C LINVRT... INVERT LOWER TRIANGULAR MATRIX.
C LITVMU... APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C LSQRT.... COMPUTE CHOLESKY FACTOR OF (LOWER TRINAG. OF) A SYM. MATRIX.
C LTSQAR... GIVEN LOWER TRIANG. MATRIX L, COMPUTE (L**T)*L.
C QRFACT... COMPUTE QR DECOMPOSITION OF A MATRIX.
C VCOPY.... COPY ONE VECTOR TO ANOTHER.
C VSCOPY... SET ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER COVMAT, COVREQ, DELTA, DELTA0, DLTFDC, F, FX, G, H, IERR,
     1        IPIVOT, IPIV0, KAGQT, KALM, LMAT, MODE, NFGCAL, QTR,
     2        RD, RSAVE, SAVEI, SWITCH, TOOBIG, W, XMSAVE
C
C/6
      DATA HALF/0.5D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, TWO/2.D+0/,
     1     ZERO/0.D+0/
C/7
C     PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0,
C    1     ZERO=0.D+0)
C/
C
C/6
      DATA COVMAT/26/, COVREQ/15/, DELTA/50/, DELTA0/44/,
     1     DLTFDC/40/, F/10/, FX/46/, G/28/, H/44/, IERR/32/,
     2     IPIVOT/61/, IPIV0/60/, KAGQT/35/, KALM/36/,
     3     LMAT/58/, MODE/38/, NFGCAL/7/, QTR/49/,
     4     RD/51/, RSAVE/52/, SAVEI/54/, SWITCH/12/,
     5     TOOBIG/2/, W/59/, XMSAVE/49/
C/7
C     PARAMETER (COVMAT=26, COVREQ=15, DELTA=50, DELTA0=44,
C    1     DLTFDC=40, F=10, FX=46, G=28, H=44, IERR=32,
C    2     IPIVOT=61, IPIV0=60, KAGQT=35, KALM=36,
C    3     LMAT=58, MODE=38, NFGCAL=7, QTR=49,
C    4     RD=51, RSAVE=52, SAVEI=54, SWITCH=12,
C    5     TOOBIG=2, W=59, XMSAVE=49)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      COVIRC = 4
      KIND = IV(COVREQ)
      M = IV(MODE)
      IF (M .GT. 0) GO TO 10
         IV(KAGQT) = -1
         IF (IV(KALM) .GT. 0) IV(KALM) = 0
         IF (IABS(KIND) .GE. 3) GO TO 300
         V(FX) = V(F)
         K = IV(RSAVE)
         CALL VCOPY(N, V(K), R)
 10   IF (M .GT. P) GO TO 200
      IF (KIND .LT. 0) GO TO 100
C
C  ***  COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
C  ***  GRADIENT VALUES.
C
      GSAVE1 = IV(W) + P
      G1 = IV(G)
      IF (M .GT. 0) GO TO 15
C        ***  FIRST CALL ON COVCLC.  SET GSAVE = G, TAKE FIRST STEP  ***
         CALL VCOPY(P, V(GSAVE1), V(G1))
         IV(SWITCH) = IV(NFGCAL)
         GO TO 80
C
 15   DEL = V(DELTA)
      X(M) = V(XMSAVE)
      IF (IV(TOOBIG) .EQ. 0) GO TO 30
C
C     ***  HANDLE OVERSIZE V(DELTA)  ***
C
         IF (DEL*X(M) .GT. ZERO) GO TO 20
C             ***  WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT  ***
              IV(COVMAT) = -2
              GO TO 190
C
C        ***  TRY SHRINKING V(DELTA)  ***
 20      DEL = NEGPT5 * DEL
         GO TO 90
C
 30   COV = IV(LMAT)
      GP = G1 + P - 1
C
C  ***  SET  G = (G - GSAVE)/DEL  ***
C
      DO 40 I = G1, GP
         V(I) = (V(I) - V(GSAVE1)) / DEL
         GSAVE1 = GSAVE1 + 1
 40      CONTINUE
C
C  ***  ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX  ***
C
      K = COV + M*(M-1)/2
      L = K + M - 2
      IF ( M .EQ. 1) GO TO 60
C
C  ***  SET  H(I,M) = 0.5 * (H(I,M) + G(I))  FOR I = 1 TO M-1  ***
C
      DO 50 I = K, L
         V(I) = HALF * (V(I) + V(G1))
         G1 = G1 + 1
 50      CONTINUE
C
C  ***  ADD  H(I,M) = G(I)  FOR I = M TO P  ***
C
 60   L = L + 1
      DO 70 I = M, P
         V(L) = V(G1)
         L = L + I
         G1 = G1 + 1
 70      CONTINUE
C
 80   M = M + 1
      IV(MODE) = M
      IF (M .GT. P) GO TO 190
C
C  ***  CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE  ***
C
      DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
      IF (X(M) .LT. ZERO) DEL = -DEL
      V(XMSAVE) = X(M)
 90   X(M) = X(M) + DEL
      V(DELTA) = DEL
      COVIRC = 2
      GO TO 999
C
C  ***  COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
C
 100  STP0 = IV(W) + P - 1
      MM1 = M - 1
      MM1O2 = M*MM1/2
      IF (M .GT. 0) GO TO 105
C        ***  FIRST CALL ON COVCLC.  ***
         IV(SAVEI) = 0
         GO TO 180
C
 105  I = IV(SAVEI)
      IF (I .GT. 0) GO TO 160
      IF (IV(TOOBIG) .EQ. 0) GO TO 120
C
C     ***  HANDLE OVERSIZE STEP  ***
C
         STPM = STP0 + M
         DEL = V(STPM)
         IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 110
C             ***  WE ALREADY TRIED SHRINKING THE STEP, SO QUIT  ***
              IV(COVMAT) = -2
              GO TO 999
C
C        ***  TRY SHRINKING THE STEP  ***
 110     DEL = NEGPT5 * DEL
         X(M) = X(XMSAVE) + DEL
         V(STPM) = DEL
         COVIRC = 1
         GO TO 999
C
C  ***  SAVE F(X + STP(M)*E(M)) IN H(P,M)  ***
C
 120  PP1O2 = P * (P-1) / 2
      COV = IV(LMAT)
      HPM = COV + PP1O2 + MM1
      V(HPM) = V(F)
C
C  ***  START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H.  ***
C
      HMI = COV + MM1O2
      IF (MM1 .EQ. 0) GO TO 140
      HPI = COV + PP1O2
      DO 130 I = 1, MM1
         V(HMI) = V(FX) - (V(F) + V(HPI))
         HMI = HMI + 1
         HPI = HPI + 1
 130     CONTINUE
 140  V(HMI) = V(F) - TWO*V(FX)
C
C  ***  COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H.  ***
C
      I = 1
C
 150  IV(SAVEI) = I
      STPI = STP0 + I
      V(DELTA) = X(I)
      X(I) = X(I) + V(STPI)
      IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI)
      COVIRC = 1
      GO TO 999
C
 160  X(I) = V(DELTA)
      IF (IV(TOOBIG) .EQ. 0) GO TO 170
C        ***  PUNT IN THE EVENT OF AN OVERSIZE STEP  ***
         IV(COVMAT) = -2
         GO TO 999
C
C  ***  FINISH COMPUTING H(M,I)  ***
C
 170  STPI = STP0 + I
      HMI = COV + MM1O2 + I - 1
      STPM = STP0 + M
      V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
      I = I + 1
      IF (I .LE. M) GO TO 150
      IV(SAVEI) = 0
      X(M) = V(XMSAVE)
C
 180  M = M + 1
      IV(MODE) = M
      IF (M .GT. P) GO TO 190
C
C  ***  PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
C  ***  COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
C  ***  F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
C
      DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(X(M)))
      IF (X(M) .LT. ZERO) DEL = -DEL
      V(XMSAVE) = X(M)
      X(M) = X(M) + DEL
      STPM = STP0 + M
      V(STPM) = DEL
      COVIRC = 1
      GO TO 999
C
C  ***  RESTORE R, V(F), ETC.  ***
C
 190  K = IV(RSAVE)
      CALL VCOPY(N, R, V(K))
      V(F) = V(FX)
      IF (KIND .LT. 0) GO TO 200
         IV(NFGCAL) = IV(SWITCH)
         QTR1 = IV(QTR)
         CALL VCOPY(N, V(QTR1), R)
         IF (IV(COVMAT) .LT. 0) GO TO 999
         COVIRC = 3
         GO TO 999
C
 200  COV = IV(LMAT)
C
C  ***  THE COMPLETE FINITE-DIFF. HESSIAN IS NOW STORED AT V(COV).   ***
C  ***  USE IT TO COMPUTE THE REQUESTED COVARIANCE MATRIX.           ***
C
C     ***  COMPUTE CHOLESKY FACTOR C OF H = C*(C**T)  ***
C     ***  AND STORE IT AT V(HC).  ***
C
      HC = COV
      IF (IABS(KIND) .EQ. 2) GO TO 210
         HC = IABS(IV(H))
         IV(H) = -HC
 210  CALL LSQRT(1, P, V(HC), V(COV), IRC)
      IV(COVMAT) = -1
      IF (IRC .NE. 0) GO TO 999
C
      W1 = IV(W) + P
      IF (IABS(KIND) .GT. 1) GO TO 350
C
C  ***  COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1  ***
C
      CALL VSCOPY(P*(P+1)/2, V(COV), ZERO)
      HAVEJ = IV(KALM) .EQ. (-1)
C     ***  HAVEJ = .TRUE. MEANS J IS IN ITS ORIGINAL FORM, WHILE
C     ***  HAVEJ = .FALSE. MEANS QRFACT HAS BEEN APPLIED TO J.
C
      M = P
      IF (HAVEJ) M = N
      W0 = W1 - 1
      RD1 = IV(RD)
      DO 290 I = 1, M
         IF (HAVEJ) GO TO 240
C
C        ***  SET W = IPIVOT * (ROW I OF R MATRIX FROM QRFACT).  ***
C
              CALL VSCOPY(P, V(W1), ZERO)
              IPIVI = IPIV0 + I
              L = W0 + IV(IPIVI)
              V(L) = V(RD1)
              RD1 = RD1 + 1
              IF (I .EQ. P) GO TO 260
              IP1 = I + 1
              DO 230 K = IP1, P
                   IPIVK = IPIV0 + K
                   L = W0 + IV(IPIVK)
                   V(L) = J(I,K)
 230               CONTINUE
              GO TO 260
C
C        ***  SET W = (ROW I OF J).  ***
C
 240     L = W0
         DO 250 K = 1, P
              L = L + 1
              V(L) = J(I,K)
 250          CONTINUE
C
C        ***  SET W = H**-1 * W.  ***
C
 260     CALL LIVMUL(P, V(W1), V(HC), V(W1))
         CALL LITVMU(P, V(W1), V(HC), V(W1))
C
C        ***  ADD  W * W**T  TO COVARIANCE MATRIX.  ***
C
         KL = COV
         DO 280 K = 1, P
              L = W0 + K
              WK = V(L)
              DO 270 L = 1, K
                   WL = W0 + L
                   V(KL) = V(KL)  +  WK * V(WL)
                   KL = KL + 1
 270               CONTINUE
 280          CONTINUE
 290     CONTINUE
      GO TO 380
C
C  ***  COVARIANCE = SCALE * (J**T * J)**-1.  ***
C
 300  RD1 = IV(RD)
      IF (IV(KALM) .NE. (-1)) GO TO 310
C
C        ***  APPLY QRFACT TO J  ***
C
         QTR1 = IV(QTR)
         CALL VCOPY(N, V(QTR1), R)
         W1 = IV(W) + P
         CALL QRFACT(NN, N, P, J, V(RD1), IV(IPIVOT), IV(IERR), 0,
     1               V(W1))
         IV(KALM) = -2
 310  IV(COVMAT) = -1
      IF (IV(IERR) .NE. 0) GO TO 999
      COV = IV(LMAT)
      HC = IABS(IV(H))
      IV(H) = -HC
C
C     ***  SET HC = (R MATRIX FROM QRFACT).  ***
C
      L = HC
      DO 340 I = 1, P
         IF (I .GT. 1) CALL VCOPY(I-1, V(L), J(1,I))
         L = L + I - 1
         V(L) = V(RD1)
         L = L + 1
         RD1 = RD1 + 1
 340     CONTINUE
C
C  ***  THE CHOLESKY FACTOR C OF THE UNSCALED INVERSE COVARIANCE MATRIX
C  ***  (OR PERMUTATION THEREOF) IS STORED AT V(HC).
C
C  ***  SET C = C**-1.
C
 350  CALL LINVRT(P, V(HC), V(HC))
C
C  ***  SET C = C**T * C.
C
      CALL LTSQAR(P, V(HC), V(HC))
C
      IF (HC .EQ. COV) GO TO 380
C
C     ***  C = PERMUTED, UNSCALED COVARIANCE.
C     ***  SET COV = IPIVOT * C * IPIVOT**T.
C
         DO 370 I = 1, P
              M = IPIV0 + I
              IPIVI = IV(M)
              KL = COV-1 + IPIVI*(IPIVI-1)/2
              DO 360 K = 1, I
                   M = IPIV0 + K
                   IPIVK = IV(M)
                   L = KL + IPIVK
                   IF (IPIVK .GT. IPIVI)
     1                       L = L + (IPIVK-IPIVI)*(IPIVK+IPIVI-3)/2
                   V(L) = V(HC)
                   HC = HC + 1
 360               CONTINUE
 370          CONTINUE
C
 380  IV(COVMAT) = COV
C
C  ***  APPLY SCALE FACTOR = (RESID. SUM OF SQUARES) / MAX(1,N-P).
C
      T = V(F) / (HALF * FLOAT(MAX0(1,N-P)))
      K = COV - 1 + P*(P+1)/2
      DO 390 I = COV, K
 390     V(I) = T * V(I)
C
 999  RETURN
C  ***  LAST CARD OF COVCLC FOLLOWS  ***
      END
      SUBROUTINE DFAULT(IV, V)                                          DFA00010
C
C  ***  SUPPLY NL2SOL (VERSION 2.2) DEFAULT VALUES TO IV AND V  ***
C
      INTEGER IV(25)
      DOUBLE PRECISION V(45)
C/+
      DOUBLE PRECISION DMAX1
C/
      EXTERNAL IMDCON, RMDCON
      INTEGER IMDCON
      DOUBLE PRECISION RMDCON
C
      DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER AFCTOL, COSMIN, COVPRT, COVREQ, DECFAC, DELTA0, DFAC,
     1        DINIT, DLTFDC, DLTFDJ, DTYPE, D0INIT, EPSLON, FUZZ,
     2        INCFAC, INITS, JTINIT, LMAX0, MXFCAL, MXITER, OUTLEV,
     3        PARPRT, PHMNFC, PHMXFC, PRUNIT, RDFCMN, RDFCMX,
     4        RFCTOL, RLIMIT, SOLPRT, STATPR, TUNER1, TUNER2, TUNER3,
     5        TUNER4, TUNER5, XCTOL, XFTOL, X0PRT
C
C/6
      DATA ONE/1.D+0/, THREE/3.D+0/
C/7
C     PARAMETER (ONE=1.D+0, THREE=3.D+0)
C/
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA COVPRT/14/, COVREQ/15/, DTYPE/16/, INITS/25/,
     1     MXFCAL/17/, MXITER/18/, OUTLEV/19/,
     2     PARPRT/20/, PRUNIT/21/, SOLPRT/22/,
     3     STATPR/23/, X0PRT/24/
C/7
C     PARAMETER (COVPRT=14, COVREQ=15, DTYPE=16, INITS=25,
C    1     MXFCAL=17, MXITER=18, OUTLEV=19,
C    2     PARPRT=20, PRUNIT=21, SOLPRT=22,
C    3     STATPR=23, X0PRT=24)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA AFCTOL/31/, COSMIN/43/, DECFAC/22/,
     1     DELTA0/44/, DFAC/41/, DINIT/38/, DLTFDC/40/,
     2     DLTFDJ/36/, D0INIT/37/, EPSLON/19/, FUZZ/45/,
     3     INCFAC/23/, JTINIT/39/, LMAX0/35/, PHMNFC/20/,
     4     PHMXFC/21/, RDFCMN/24/, RDFCMX/25/,
     5     RFCTOL/32/, RLIMIT/42/, TUNER1/26/,
     6     TUNER2/27/, TUNER3/28/, TUNER4/29/,
     7     TUNER5/30/, XCTOL/33/, XFTOL/34/
C/7
C     PARAMETER (AFCTOL=31, COSMIN=43, DECFAC=22,
C    1     DELTA0=44, DFAC=41, DINIT=38, DLTFDC=40,
C    2     DLTFDJ=36, D0INIT=37, EPSLON=19, FUZZ=45,
C    3     INCFAC=23, JTINIT=39, LMAX0=35, PHMNFC=20,
C    4     PHMXFC=21, RDFCMN=24, RDFCMX=25,
C    5     RFCTOL=32, RLIMIT=42, TUNER1=26,
C    6     TUNER2=27, TUNER3=28, TUNER4=29,
C    7     TUNER5=30, XCTOL=33, XFTOL=34)
C/
C
C-----------------------------------------------------------------------
C
      IV(1) = 12
      IV(COVPRT) = 1
      IV(COVREQ) = 1
      IV(DTYPE) = 1
      IV(INITS) = 0
      IV(MXFCAL) = 200
      IV(MXITER) = 150
      IV(OUTLEV) = 1
      IV(PARPRT) = 1
      IV(PRUNIT) = IMDCON(1)
      IV(SOLPRT) = 1
      IV(STATPR) = 1
      IV(X0PRT) = 1
C
      MACHEP = RMDCON(3)
      V(AFCTOL) = 1.D-20
      IF (MACHEP .GT. 1.D-10) V(AFCTOL) = MACHEP**2
      V(COSMIN) = DMAX1(1.D-6, 1.D+2 * MACHEP)
      V(DECFAC) = 0.5D+0
      SQTEPS = RMDCON(4)
      V(DELTA0) = SQTEPS
      V(DFAC) = 0.6D+0
      V(DINIT) = 0.D+0
      MEPCRT = MACHEP ** (ONE/THREE)
      V(DLTFDC) = MEPCRT
      V(DLTFDJ) = SQTEPS
      V(D0INIT) = 1.D+0
      V(EPSLON) = 0.1D+0
      V(FUZZ) = 1.5D+0
      V(INCFAC) = 2.D+0
      V(JTINIT) = 1.D-6
      V(LMAX0) = 100.D+0
      V(PHMNFC) = -0.1D+0
      V(PHMXFC) = 0.1D+0
      V(RDFCMN) = 0.1D+0
      V(RDFCMX) = 4.D+0
      V(RFCTOL) = DMAX1(1.D-10, MEPCRT**2)
      V(RLIMIT) = RMDCON(5)
      V(TUNER1) = 0.1D+0
      V(TUNER2) = 1.D-4
      V(TUNER3) = 0.75D+0
      V(TUNER4) = 0.5D+0
      V(TUNER5) = 0.75D+0
      V(XCTOL) = SQTEPS
      V(XFTOL) = 1.D+2 * MACHEP
C
 999  RETURN
C  ***  LAST CARD OF DFAULT FOLLOWS  ***
      END
      DOUBLE PRECISION FUNCTION DOTPRD(P, X, Y)                         DOT00010
C
C  ***  RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y.  ***
C
      INTEGER P
      DOUBLE PRECISION X(P), Y(P)
C
      INTEGER I
      DOUBLE PRECISION ONE, SQTETA, T, ZERO
C/+
      DOUBLE PRECISION DMAX1, DABS
C/
      EXTERNAL RMDCON
      DOUBLE PRECISION RMDCON
C
C  ***  RMDCON(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH
C  ***  IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT
C  ***  CAN BE SQUARED WITHOUT UNDERFLOWING.
C
C/6
      DATA ONE/1.D+0/, SQTETA/0.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C     DATA SQTETA/0.D+0/
C/
C
      DOTPRD = ZERO
      IF (P .LE. 0) GO TO 999
      IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2)
      DO 20 I = 1, P
         T = DMAX1(DABS(X(I)), DABS(Y(I)))
         IF (T .GT. ONE) GO TO 10
         IF (T .LT. SQTETA) GO TO 20
         T = (X(I)/SQTETA)*Y(I)
         IF (DABS(T) .LT. SQTETA) GO TO 20
 10      DOTPRD = DOTPRD + X(I)*Y(I)
 20   CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF DOTPRD FOLLOWS  ***
      END
      SUBROUTINE DUPDAT(D, IV, J, N, NN, P, V)                          DUP00010
C
C  ***  UPDATE SCALE VECTOR D FOR NL2ITR (NL2SOL VERSION 2.2)  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IV(1), N, NN, P
      DOUBLE PRECISION D(P), J(NN,P), V(1)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER D0, I, JTOLI, S1
      DOUBLE PRECISION SII, T, VDFAC
C
C     ***  CONSTANTS  ***
      DOUBLE PRECISION ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      DOUBLE PRECISION DMAX1, DSQRT
C/
C  ***  EXTERNAL FUNCTION  ***
C
      EXTERNAL V2NORM
      DOUBLE PRECISION V2NORM
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER DFAC, DTYPE, JTOL0, NITER, S
C/6
      DATA DFAC/41/, DTYPE/16/, JTOL0/86/, NITER/31/, S/53/
C/7
C     PARAMETER (DFAC=41, DTYPE=16, JTOL0=86, NITER=31, S=53)
C/
C
C/6
      DATA ZERO/0.D+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
C-----------------------------------------------------------------------
C
      I = IV(DTYPE)
      IF (I .EQ. 1) GO TO 20
         IF (IV(NITER) .GT. 0) GO TO 999
C
 20   VDFAC = V(DFAC)
      D0 = JTOL0 + P
      S1 = IV(S) - 1
      DO 30 I = 1, P
         S1 = S1 + I
         SII = V(S1)
         T = V2NORM(N, J(1,I))
         IF (SII .GT. ZERO) T = DSQRT(T*T + SII)
         JTOLI = JTOL0 + I
         D0 = D0 + 1
         IF (T .LT. V(JTOLI)) T = DMAX1(V(D0), V(JTOLI))
         D(I) = DMAX1(VDFAC*D(I), T)
 30      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF DUPDAT FOLLOWS  ***
      END
      SUBROUTINE GQTSTP(D, DIG, DIHDI, KA, L, P, STEP, V, W)            GQT00010
C
C  *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER KA, P
      DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P),
     1                 W(1)
C     DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C        GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
C     HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
C     THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
C     APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE.  IN
C     OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
C     PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP  SUCH THAT THE
C     2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE
C     G  IS THE GRADIENT,  H  IS THE HESSIAN, AND  D  IS A DIAGONAL
C     SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
C     (GQTSTP ASSUMES  DIG = D**-1 * G  AND  DIHDI = D**-1 * H * D**-1.)
C     IF G = 0, HOWEVER, STEP = 0 IS RETURNED (EVEN AT A SADDLE POINT).
C
C  ***  PARAMETER DESCRIPTION  ***
C
C     D (IN)  = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
C              MATRIX  D  MENTIONED ABOVE UNDER PURPOSE.
C   DIG (IN)  = THE SCALED GRADIENT VECTOR, D**-1 * G.  IF G = 0, THEN
C              STEP = 0  AND  V(STPPAR) = 0  ARE RETURNED.
C DIHDI (IN)  = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
C              I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
C              IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
C    KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
C              MINE STEP.  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
C              ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
C              -- KA IS INITIALIZED TO 0 IN THIS CASE.  OUTPUT WITH
C              KA = 0  (OR V(STPPAR) = 0)  MEANS  STEP = -(H**-1)*G.
C     L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
C     P (IN)  = NUMBER OF PARAMETERS -- THE HESSIAN IS A  P X P  MATRIX.
C  STEP (I/O) = THE STEP COMPUTED.
C     V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C     W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
C
C  ***  ENTRIES IN V  ***
C
C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP.
C V(DST0)   (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
C             OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
C V(EPSLON) (IN)  = MAX. REL. ERROR ALLOWED FOR PSI(STEP).  FOR THE
C             STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
C             BY LESS THAN -V(EPSLON)*PSI(STEP).  SUGGESTED VALUE = 0.1.
C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP)  (FOR POS. DEF.
C             H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE).
C V(PHMNFC) (IN)  = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
C             BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
C V(PHMXFC) (IN)  (SEE V(PHMNFC).)
C             SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5.
C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
C V(RADIUS) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(RAD0)   (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
C             DESCRIBED BELOW UNDER ALGORITHM NOTES.  IF H + ALPHA*D**2
C             (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
C             THEN V(STPPAR) = -ALPHA.
C
C  ***  USAGE NOTES  ***
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS).  (THIS EXPLAINS
C     WHY STEP AND W ARE LISTED AS I/O).  ON AN INTIIAL CALL (ONE WITH
C     KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
C     NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND
C     V(RAD0) OF V MUST BE INITIALIZED.  TO COMPUTE STEP FROM A SADDLE
C     POINT (WHERE THE TRUE GRADIENT VANISHES AND H HAS A NEGATIVE
C     EIGENVALUE), A NONZERO G WITH SMALL COMPONENTS SHOULD BE PASSED.
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
C     SQUARES) PACKAGE (REF. 1), BUT IT COULD BE USED IN SOLVING ANY
C     UNCONSTRAINED MINIMIZATION PROBLEM.
C
C  ***  ALGORITHM NOTES  ***
C
C        THE DESIRED G-Q-T STEP (REF. 2, 3, 4) SATISFIES
C     (H + ALPHA*D**2)*STEP = -G  FOR SOME NONNEGATIVE ALPHA SUCH THAT
C     H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE.  ALPHA AND STEP ARE
C     COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
C     ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
C     ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
C     SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 6.  CASES IN WHICH
C     H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
C     THE TECHNIQUE DISCUSSED IN REF. 2.  IN THESE CASES, A STEP OF
C     (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
C     ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP).
C
C  ***  FUNCTIONS AND SUBROUTINES CALLED  ***
C
C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS.
C LITVMU - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C LSQRT  - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
C LSVMIN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
C RMDCON - RETURNS MACHINE-DEPENDENT CONSTANTS.
C V2NORM - RETURNS 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C 2.  GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
C             SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
C             186-197.
C 3.  GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
C             MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
C             PP. 541-551.
C 4.  HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
C             SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
C             DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
C 5.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C 6.  VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
C             PP. 719-729.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      LOGICAL RESTRT
      INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC,
     1        J, K, KALIM, K1, LK0, PHIPIN, Q, Q0, UK0, X, X0
      DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPSO6, LK,
     1                 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
     2                 ROOT, SI, SK, SW, T, TWOPSI, T1, UK, WI
C
C     ***  CONSTANTS  ***
      DOUBLE PRECISION DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, ONE,
     1                 P001, SIX, THREE, TWO, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      DOUBLE PRECISION DABS, DMAX1, DMIN1, DSQRT
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DOTPRD, LITVMU, LIVMUL, LSQRT, LSVMIN, RMDCON, V2NORM
      DOUBLE PRECISION DOTPRD, LSVMIN, RMDCON, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
      INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC,
     1        PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0
C/6
      DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/,
     1     GTSTEP/4/, NREDUC/6/, PHMNFC/20/,
     2     PHMXFC/21/, PREDUC/7/, RADIUS/8/,
     3     RAD0/9/, STPPAR/5/
C/7
C     PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19,
C    1     GTSTEP=4, NREDUC=6, PHMNFC=20,
C    2     PHMXFC=21, PREDUC=7, RADIUS=8,
C    3     RAD0=9, STPPAR=5)
C/
C
C/6
      DATA EPSFAC/50.0D+0/, FOUR/4.0D+0/, HALF/0.5D+0/,
     1     KAPPA/2.0D+0/, NEGONE/-1.0D+0/, ONE/1.0D+0/, P001/1.0D-3/,
     2     SIX/6.0D+0/, THREE/3.0D+0/, TWO/2.0D+0/, ZERO/0.0D+0/
C/7
C     PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0,
C    1     KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3,
C    2     SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0)
C     SAVE DGXFAC
C/
      DATA DGXFAC/0.D+0/
C
C  ***  BODY  ***
C
C     ***  STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX).
      DGGDMX = P + 1
C     ***  STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST
C     ***  AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX)
C     ***  AND W(EMIN) RESPECTIVELY.
      EMAX = DGGDMX + 1
      EMIN = EMAX + 1
C     ***  FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST,
C     ***  AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF.
C     ***  H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN)
C     ***  RESPECTIVELY.
      LK0 = EMIN + 1
      PHIPIN = LK0 + 1
      UK0 = PHIPIN + 1
      DSTSAV = UK0 + 1
C     ***  STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P).
      DIAG0 = DSTSAV
      DIAG = DIAG0 + 1
C     ***  STORE -D*STEP IN W(Q),...,W(Q0+P).
      Q0 = DIAG0 + P
      Q = Q0 + 1
      RAD = V(RADIUS)
C     ***  PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF
C     ***  D*STEP.
      PHIMAX = V(PHMXFC) * RAD
      PHIMIN = V(PHMNFC) * RAD
C     ***  EPSO6 AND PSIFAC ARE USED IN CHECKING FOR THE SPECIAL CASE
C     ***  OF (NEARLY) SINGULAR H + ALPHA*D**2 (SEE REF. 2).
      PSIFAC = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) *
     1                       (KAPPA + ONE)  +  KAPPA  +  TWO) * RAD**2)
C     ***  OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY.  IF
C     ***  WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
      OLDPHI = ZERO
      EPSO6 = V(EPSLON)/SIX
      IRC = 0
      RESTRT = .FALSE.
      KALIM = KA + 50
C
C  ***  START OR RESTART, DEPENDING ON KA  ***
C
      IF (KA .GE. 0) GO TO 310
C
C  ***  FRESH START  ***
C
      K = 0
      UK = NEGONE
      KA = 0
      KALIM = 50
C
C     ***  STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P)  ***
C
      J = 0
      DO 20 I = 1, P
         J = J + I
         K1 = DIAG0 + I
         W(K1) = DIHDI(J)
 20      CONTINUE
C
C     ***  DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI  ***
C
      T1 = ZERO
      J = P * (P + 1) / 2
      DO 30 I = 1, J
         T = DABS(DIHDI(I))
         IF (T1 .LT. T) T1 = T
 30      CONTINUE
      W(DGGDMX) = T1
C
C  ***  TRY ALPHA = 0  ***
C
 40   CALL LSQRT(1, P, L, DIHDI, IRC)
      IF (IRC .EQ. 0) GO TO 60
C        ***  INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS
C        ***  ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA.
         J = IRC*(IRC+1)/2
         T = L(J)
         L(J) = ONE
         DO 50 I = 1, IRC
 50           W(I) = ZERO
         W(IRC) = ONE
         CALL LITVMU(IRC, W, L, W)
         T1 = V2NORM(IRC, W)
         LK = -T / T1 / T1
         V(DST0) = -LK
         IF (RESTRT) GO TO 210
         V(NREDUC) = ZERO
         GO TO 70
C
C     ***  POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP.  ***
 60   LK = ZERO
      CALL LIVMUL(P, W(Q), L, DIG)
      V(NREDUC) = HALF * DOTPRD(P, W(Q), W(Q))
      CALL LITVMU(P, W(Q), L, W(Q))
      DST = V2NORM(P, W(Q))
      V(DST0) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GO TO 280
      IF (RESTRT) GO TO 210
C
C  ***  PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND
C  ***  SMALLEST) EIGENVALUES.  ***
C
 70   V(DGNORM) = V2NORM(P, DIG)
      IF (V(DGNORM) .EQ. ZERO) GO TO 450
      K = 0
      DO 100 I = 1, P
         WI = ZERO
         IF (I .EQ. 1) GO TO 90
         IM1 = I - 1
         DO 80 J = 1, IM1
              K = K + 1
              T = DABS(DIHDI(K))
              WI = WI + T
              W(J) = W(J) + T
 80           CONTINUE
 90      W(I) = WI
         K = K + 1
 100     CONTINUE
C
C  ***  (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1)  ***
C
      K = 1
      T1 = W(DIAG) - W(1)
      IF (P .LE. 1) GO TO 120
      DO 110 I = 2, P
         J = DIAG0 + I
         T = W(J) - W(I)
         IF (T .GE. T1) GO TO 110
              T1 = T
              K = I
 110     CONTINUE
C
 120  SK = W(K)
      J = DIAG0 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = ZERO
      DO 150 I = 1, P
         IF (I .EQ. K) GO TO 130
         AKI = DABS(DIHDI(K1))
         SI = W(I)
         J = DIAG0 + I
         T1 = HALF * (AKK - W(J) + SI - AKI)
         T1 = T1 + DSQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GO TO 140
 130     INC = I
 140     K1 = K1 + INC
 150     CONTINUE
C
      W(EMIN) = AKK - T
      UK = V(DGNORM)/RAD - W(EMIN)
C
C  ***  COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE  ***
C
      K = 1
      T1 = W(DIAG) + W(1)
      IF (P .LE. 1) GO TO 170
      DO 160 I = 2, P
         J = DIAG0 + I
         T = W(J) + W(I)
         IF (T .LE. T1) GO TO 160
              T1 = T
              K = I
 160     CONTINUE
C
 170  SK = W(K)
      J = DIAG0 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = ZERO
      DO 200 I = 1, P
         IF (I .EQ. K) GO TO 180
         AKI = DABS(DIHDI(K1))
         SI = W(I)
         J = DIAG0 + I
         T1 = HALF * (W(J) + SI - AKI - AKK)
         T1 = T1 + DSQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GO TO 190
 180     INC = I
 190     K1 = K1 + INC
 200     CONTINUE
C
      W(EMAX) = AKK + T
      LK = DMAX1(LK, V(DGNORM)/RAD - W(EMAX))
C
C     ***  ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE).  WE
C     ***  USE MORE*S SCHEME FOR INITIALIZING IT.
      ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD
C
      IF (IRC .NE. 0) GO TO 210
C
C  ***  COMPUTE L0 FOR POSITIVE DEFINITE H  ***
C
      CALL LIVMUL(P, W, L, W(Q))
      T = V2NORM(P, W)
      W(PHIPIN) = DST / T / T
      LK = DMAX1(LK, PHI*W(PHIPIN))
C
C  ***  SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1)  ***
C
 210  KA = KA + 1
      IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     1                      ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK))
      K = 0
      DO 220 I = 1, P
         K = K + I
         J = DIAG0 + I
         DIHDI(K) = W(J) + ALPHAK
 220     CONTINUE
C
C  ***  TRY COMPUTING CHOLESKY DECOMPOSITION  ***
C
      CALL LSQRT(1, P, L, DIHDI, IRC)
      IF (IRC .EQ. 0) GO TO 250
C
C  ***  (D**-1)*H*(D**-1) + ALPHAK*I  IS INDEFINITE -- OVERESTIMATE
C  ***  SMALLEST EIGENVALUE FOR USE IN UPDATING LK  ***
C
      J = (IRC*(IRC+1))/2
      T = L(J)
      L(J) = ONE
      DO 230 I = 1, IRC
 230     W(I) = ZERO
      W(IRC) = ONE
      CALL LITVMU(IRC, W, L, W)
      T1 = V2NORM(IRC, W)
      LK = ALPHAK - T/T1/T1
      V(DST0) = -LK
      GO TO 210
C
C  ***  ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE.
C  ***  COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE.  ***
C
 250  CALL LIVMUL(P, W(Q), L, DIG)
      CALL LITVMU(P, W(Q), L, W(Q))
      DST = V2NORM(P, W(Q))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 290
      IF (PHI .EQ. OLDPHI) GO TO 290
      OLDPHI = PHI
      IF (PHI .GT. ZERO) GO TO 260
C        ***  CHECK FOR THE SPECIAL CASE OF  H + ALPHA*D**2  (NEARLY)
C        ***  SINGULAR.  DELTA IS .GE. THE SMALLEST EIGENVALUE OF
C        ***  (D**-1)*H*(D**-1) + ALPHAK*I.
         IF (V(DST0) .GT. ZERO) GO TO 260
         DELTA = ALPHAK + V(DST0)
         TWOPSI = ALPHAK*DST*DST + DOTPRD(P, DIG, W(Q))
         IF (DELTA .LT. PSIFAC*TWOPSI) GO TO 270
C
C  ***  UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK  ***
C
 260  IF (KA .GE. KALIM) GO TO 290
      CALL LIVMUL(P, W, L, W(Q))
      T1 = V2NORM(P, W)
C     ***  THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS  ***
      IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK)
      ALPHAK = ALPHAK  +  (PHI/T1) * (DST/T1) * (DST/RAD)
      LK = DMAX1(LK, ALPHAK)
      GO TO 210
C
C  ***  DECIDE HOW TO HANDLE (NEARLY) SINGULAR H + ALPHA*D**2  ***
C
C     ***  IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC.
 270  IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * RMDCON(3)
C
C     ***  NOW DECIDE.  ***
      IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 350
C        ***  DELTA IS SO SMALL WE CANNOT HANDLE THE SPECIAL CASE IN
C        ***  THE AVAILABLE ARITHMETIC.  ACCEPT STEP AS IT IS.
         GO TO 290
C
C  ***  ACCEPTABLE STEP ON FIRST TRY  ***
C
 280  ALPHAK = ZERO
C
C  ***  SUCCESSFUL STEP IN GENERAL.  COMPUTE STEP = -(D**-1)*Q  ***
C
 290  DO 300 I = 1, P
         J = Q0 + I
         STEP(I) = -W(J)/D(I)
 300     CONTINUE
      V(GTSTEP) = -DOTPRD(P, DIG, W(Q))
      V(PREDUC) = HALF * (DABS(ALPHAK)*DST*DST - V(GTSTEP))
      GO TO 430
C
C
C  ***  RESTART WITH NEW RADIUS  ***
C
 310  IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 330
C
C     ***  PREPARE TO RETURN NEWTON STEP  ***
C
         RESTRT = .TRUE.
         KA = KA + 1
         K = 0
         DO 320 I = 1, P
              K = K + I
              J = DIAG0 + I
              DIHDI(K) = W(J)
 320          CONTINUE
         UK = NEGONE
         GO TO 40
C
 330  IF (KA .EQ. 0) GO TO 60
C
      DST = W(DSTSAV)
      ALPHAK = DABS(V(STPPAR))
      PHI = DST - RAD
      T = V(DGNORM)/RAD
      IF (RAD .GT. V(RAD0)) GO TO 340
C
C        ***  SMALLER RADIUS  ***
         UK = T - W(EMIN)
         LK = ZERO
         IF (ALPHAK .GT. ZERO) LK = W(LK0)
         LK = DMAX1(LK, T - W(EMAX))
         IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
         GO TO 260
C
C     ***  BIGGER RADIUS  ***
 340  UK = T - W(EMIN)
      IF (ALPHAK .GT. ZERO) UK = DMIN1(UK, W(UK0))
      LK = DMAX1(ZERO, -V(DST0), T - W(EMAX))
      IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
      GO TO 260
C
C  ***  HANDLE (NEARLY) SINGULAR H + ALPHA*D**2  ***
C
C     ***  NEGATE ALPHAK TO INDICATE SPECIAL CASE  ***
 350  ALPHAK = -ALPHAK
C     ***  ALLOCATE STORAGE FOR SCRATCH VECTOR X  ***
      X0 = Q0 + P
      X = X0 + 1
C
C  ***  USE INVERSE POWER METHOD WITH START FROM LSVMIN TO OBTAIN
C  ***  APPROXIMATE EIGENVECTOR CORRESPONDING TO SMALLEST EIGENVALUE
C  ***  OF (D**-1)*H*(D**-1).
C
      DELTA = KAPPA*DELTA
      T = LSVMIN(P, L, W(X), W)
C
      K = 0
C     ***  NORMALIZE W  ***
 360  DO 370 I = 1, P
 370     W(I) = T*W(I)
C     ***  COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W.
      CALL LITVMU(P, W, L, W)
      T1 = ONE/V2NORM(P, W)
      T = T1*T
      IF (T .LE. DELTA) GO TO 390
      IF (K .GT. 30) GO TO 290
      K = K + 1
C     ***  START NEXT INV. POWER ITER. BY STORING NORMALIZED W IN X.
      DO 380 I = 1, P
         J = X0 + I
         W(J) = T1*W(I)
 380     CONTINUE
C     ***  COMPUTE W = (L**-1)*X.
      CALL LIVMUL(P, W, L, W(X))
      T = ONE/V2NORM(P, W)
      GO TO 360
C
 390  DO 400 I = 1, P
 400     W(I) = T1*W(I)
C
C  ***  NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND
C  ***  T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
C
      SW = DOTPRD(P, W(Q), W)
      T1 = (RAD + DST) * (RAD - DST)
      ROOT = DSQRT(SW*SW + T1)
      IF (SW .LT. ZERO) ROOT = -ROOT
      SI = T1 / (SW + ROOT)
C     ***  ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A
C     ***  FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3.
      V(PREDUC) = HALF*TWOPSI
      T1 = ZERO
      T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DOTPRD(P,W(X),W)))
      IF (T .LT. EPSO6*TWOPSI) GO TO 410
         V(PREDUC) = V(PREDUC) + T
         DST = RAD
         T1 = -SI
 410  DO 420 I = 1, P
         J = Q0 + I
         W(J) = T1*W(I) - W(J)
         STEP(I) = W(J) / D(I)
 420     CONTINUE
      V(GTSTEP) = DOTPRD(P, DIG, W(Q))
C
C  ***  SAVE VALUES FOR USE IN A POSSIBLE RESTART  ***
C
 430  V(DSTNRM) = DST
      V(STPPAR) = ALPHAK
      W(LK0) = LK
      W(UK0) = UK
      V(RAD0) = RAD
      W(DSTSAV) = DST
C
C     ***  RESTORE DIAGONAL OF DIHDI  ***
C
      J = 0
      DO 440 I = 1, P
         J = J + I
         K = DIAG0 + I
         DIHDI(J) = W(K)
 440     CONTINUE
      GO TO 999
C
C  ***  SPECIAL CASE -- G = 0  ***
C
 450  V(STPPAR) = ZERO
      V(PREDUC) = ZERO
      V(DSTNRM) = ZERO
      V(GTSTEP) = ZERO
      DO 460 I = 1, P
 460     STEP(I) = ZERO
C
 999  RETURN
C
C  ***  LAST CARD OF GQTSTP FOLLOWS  ***
      END
      SUBROUTINE ITSMRY(D, IV, P, V, X)                                 ITS00010
C
C  ***  PRINT NL2SOL (VERSION 2.2) ITERATION SUMMARY  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IV(1), P
      DOUBLE PRECISION D(P), V(1), X(P)
C     DIMENSION IV(*), V(*)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER COV1, G1, I, II, IV1, I1, J, M, NF, NG, OL, PU
C/6
      REAL MODEL1(6), MODEL2(6)
C/7
C     CHARACTER*4 MODEL1(6), MODEL2(6)
C/
      DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
C/
C  ***  NO EXTERNAL FUNCTIONS OR SUBROUTINES  ***
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER COVMAT, COVPRT, COVREQ, DSTNRM, F, FDIF, F0, G,
     1        NEEDHD, NFCALL, NFCOV, NGCOV, NGCALL, NITER, NREDUC,
     2        OUTLEV, PREDUC, PRNTIT, PRUNIT, RELDX, SIZE, SOLPRT,
     3        STATPR, STPPAR, SUSED, X0PRT
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C/6
      DATA COVMAT/26/, COVPRT/14/, G/28/, COVREQ/15/,
     1     NEEDHD/39/, NFCALL/6/, NFCOV/40/, NGCOV/41/,
     2     NGCALL/30/, NITER/31/, OUTLEV/19/, PRNTIT/48/,
     3     PRUNIT/21/, SOLPRT/22/, STATPR/23/, SUSED/57/,
     4     X0PRT/24/
C/7
C     PARAMETER (COVMAT=26, COVPRT=14, G=28, COVREQ=15,
C    1     NEEDHD=39, NFCALL=6, NFCOV=40, NGCOV=41,
C    2     NGCALL=30, NITER=31, OUTLEV=19, PRNTIT=48,
C    3     PRUNIT=21, SOLPRT=22, STATPR=23, SUSED=57,
C    4     X0PRT=24)
C/
C
C  ***  V SUBSCRIPT VALUES  ***
C
C/6
      DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/,
     1     PREDUC/7/, RELDX/17/, SIZE/47/, STPPAR/5/
C/7
C     PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6,
C    1     PREDUC=7, RELDX=17, SIZE=47, STPPAR=5)
C/
C
C/6
      DATA ZERO/0.D+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C/6
      DATA MODEL1(1)/4H    /, MODEL1(2)/4H    /, MODEL1(3)/4H    /,
     1     MODEL1(4)/4H    /, MODEL1(5)/4H  G /, MODEL1(6)/4H  S /,
     2     MODEL2(1)/4H G  /, MODEL2(2)/4H S  /, MODEL2(3)/4HG-S /,
     3     MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/
C/7
C     DATA MODEL1/'    ','    ','    ','    ','  G ','  S '/,
C    1     MODEL2/' G  ',' S  ','G-S ','S-G ','-S-G','-G-S'/
C/
C
C-----------------------------------------------------------------------
C
      PU = IV(PRUNIT)
      IF (PU .EQ. 0) GO TO 999
      IV1 = IV(1)
      OL = IV(OUTLEV)
      IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 140
      IF (OL .EQ. 0) GO TO 20
      IF (IV1 .GE. 12) GO TO 20
      IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 20
      IF (IV1 .GT. 2) GO TO 10
         IV(PRNTIT) = IV(PRNTIT) + 1
         IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999
 10   NF = IV(NFCALL) - IABS(IV(NFCOV))
      IV(PRNTIT) = 0
      RELDF = ZERO
      PRELDF = ZERO
      OLDF = V(F0)
      IF (OLDF .LE. ZERO) GO TO 12
         RELDF = V(FDIF) / OLDF
         PRELDF = V(PREDUC) / OLDF
 12   IF (OL .GT. 0) GO TO 15
C
C        ***  PRINT SHORT SUMMARY LINE  ***
C
         IF (IV(NEEDHD) .EQ. 1) WRITE(PU, 1010)
 1010 FORMAT(12H0   IT    NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX)
         IV(NEEDHD) = 0
         WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX)
         GO TO 20
C
C     ***  PRINT LONG SUMMARY LINE  ***
C
 15   IF (IV(NEEDHD) .EQ. 1) WRITE(PU,1015)
 1015 FORMAT(12H0   IT    NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX,
     1       4X,15HMODEL    STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF)
      IV(NEEDHD) = 0
      M = IV(SUSED)
      NRELDF = ZERO
      IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF
      WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
     1               MODEL1(M), MODEL2(M), V(STPPAR), V(SIZE),
     2               V(DSTNRM), NRELDF
 1017 FORMAT(1X,I5,I6,4D11.3,A3,A4,4D11.3)
C
 20   GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1
C
 30   WRITE(PU,1030)
 1030 FORMAT(26H0***** X-CONVERGENCE *****)
      GO TO 180
C
 35   WRITE(PU,1035)
 1035 FORMAT(42H0***** RELATIVE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 40   WRITE(PU,1040)
 1040 FORMAT(49H0***** X- AND RELATIVE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 45   WRITE(PU,1045)
 1045 FORMAT(42H0***** ABSOLUTE FUNCTION CONVERGENCE *****)
      GO TO 180
C
 50   WRITE(PU,1050)
 1050 FORMAT(33H0***** SINGULAR CONVERGENCE *****)
      GO TO 180
C
 60   WRITE(PU,1060)
 1060 FORMAT(30H0***** FALSE CONVERGENCE *****)
      GO TO 180
C
 70   WRITE(PU,1070)
 1070 FORMAT(38H0***** FUNCTION EVALUATION LIMIT *****)
      GO TO 180
C
 80   WRITE(PU,1080)
 1080 FORMAT(28H0***** ITERATION LIMIT *****)
      GO TO 180
C
 90   WRITE(PU,1090)
 1090 FORMAT(18H0***** STOPX *****)
      GO TO 180
C
 110  WRITE(PU,1100)
 1100 FORMAT(45H0***** INITIAL SUM OF SQUARES OVERFLOWS *****)
C
      GO TO 150
C
 120  WRITE(PU,1120)
 1120 FORMAT(37H0***** BAD PARAMETERS TO ASSESS *****)
      GO TO 999
C
 130  WRITE(PU,1130)
 1130 FORMAT(36H0***** J COULD NOT BE COMPUTED *****)
      IF (IV(NITER) .GT. 0) GO TO 190
      GO TO 150
C
 140  WRITE(PU,1140) IV1
 1140 FORMAT(14H0***** IV(1) =,I5,6H *****)
      GO TO 999
C
C  ***  INITIAL CALL ON ITSMRY  ***
C
 150  IF (IV(X0PRT) .NE. 0) WRITE(PU,1150) (I, X(I), D(I), I = 1, P)
 1150 FORMAT(23H0    I     INITIAL X(I),7X,4HD(I)//(1X,I5,D17.6,D14.3))
      IF (IV1 .GE. 13) GO TO 999
      IV(NEEDHD) = 0
      IV(PRNTIT) = 0
      IF (OL .EQ. 0) GO TO 999
      IF (OL .LT. 0) WRITE(PU,1010)
      IF (OL .GT. 0) WRITE(PU,1015)
      WRITE(PU,1160) V(F)
 1160 FORMAT(12H0    0     1,D11.3,11X,D11.3)
      GO TO 999
C
C  ***  PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION  ***
C
 180  IV(NEEDHD) = 1
      IF (IV(STATPR) .EQ. 0) GO TO 190
         OLDF = V(F0)
         PRELDF = ZERO
         NRELDF = ZERO
         IF (OLDF .LE. ZERO) GO TO 185
              PRELDF = V(PREDUC) / OLDF
              NRELDF = V(NREDUC) / OLDF
 185     NF = IV(NFCALL) - IV(NFCOV)
         NG = IV(NGCALL) - IV(NGCOV)
         WRITE(PU,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF
 1180 FORMAT(9H0FUNCTION,D17.6,8H   RELDX,D20.6/12H FUNC. EVALS,
     1   I8,9X,11HGRAD. EVALS,I8/7H PRELDF,D19.6,3X,7HNPRELDF,D18.6)
C
         IF (IV(NFCOV) .GT. 0) WRITE(PU,1185) IV(NFCOV)
 1185    FORMAT(1H0,I4,34H EXTRA FUNC. EVALS FOR COVARIANCE.)
         IF (IV(NGCOV) .GT. 0) WRITE(PU,1186) IV(NGCOV)
 1186    FORMAT(1X,I4,34H EXTRA GRAD. EVALS FOR COVARIANCE.)
C
 190  IF (IV(SOLPRT) .EQ. 0) GO TO 210
         IV(NEEDHD) = 1
         G1 = IV(G)
         WRITE(PU,1190)
 1190 FORMAT(22H0    I      FINAL X(I),8X,4HD(I),10X,4HG(I)/)
         DO 200 I = 1, P
              WRITE(PU,1200) I, X(I), D(I), V(G1)
              G1 = G1 + 1
 200          CONTINUE
 1200    FORMAT(1X,I5,D17.6,2D14.3)
C
 210  IF (IV(COVPRT) .EQ. 0) GO TO 999
      COV1 = IV(COVMAT)
      IV(NEEDHD) = 1
      IF (COV1) 220, 230, 240
 220  IF (-1 .EQ. COV1) WRITE(PU,1220)
 1220 FORMAT(43H0++++++ INDEFINITE COVARIANCE MATRIX ++++++)
      IF (-2 .EQ. COV1) WRITE(PU,1225)
 1225 FORMAT(52H0++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++)
      GO TO 999
C
 230  WRITE(PU,1230)
 1230 FORMAT(45H0++++++ COVARIANCE MATRIX NOT COMPUTED ++++++)
      GO TO 999
C
 240  I = IABS(IV(COVREQ))
      IF (I .LE. 1) WRITE(PU,1241)
 1241 FORMAT(48H0COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/)
      IF (I .EQ. 2) WRITE(PU,1242)
 1242 FORMAT(27H0COVARIANCE = SCALE * H**-1/)
      IF (I .GE. 3) WRITE(PU,1243)
 1243 FORMAT(36H0COVARIANCE = SCALE * (J**T * J)**-1/)
      II = COV1 - 1
      IF (OL .LE. 0) GO TO 260
      DO 250 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(PU,1250) I, (V(J), J = I1, II)
 250     CONTINUE
 1250 FORMAT(4H ROW,I3,2X,9D12.4/(9X,9D12.4))
      GO TO 999
C
 260  DO 270 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(PU,1270) I, (V(J), J = I1, II)
 270     CONTINUE
 1270 FORMAT(4H ROW,I3,2X,5D12.4/(9X,5D12.4))
C
 999  RETURN
C  ***  LAST CARD OF ITSMRY FOLLOWS  ***
      END
      SUBROUTINE LINVRT(N, LIN, L)                                      LIN00010
C
C  ***  COMPUTE  LIN = L**-1,  BOTH  N X N  LOWER TRIANG. STORED   ***
C  ***  COMPACTLY BY ROWS.  LIN AND L MAY SHARE THE SAME STORAGE.  ***
C
C  ***  PARAMETERS  ***
C
      INTEGER N
      DOUBLE PRECISION L(1), LIN(1)
C     DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
      DOUBLE PRECISION ONE, T, ZERO
C/6
      DATA ONE/1.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
      NP1 = N + 1
      J0 = N*(NP1)/2
      DO 30 II = 1, N
         I = NP1 - II
         LIN(J0) = ONE/L(J0)
         IF (I .LE. 1) GO TO 999
         J1 = J0
         IM1 = I - 1
         DO 20 JJ = 1, IM1
              T = ZERO
              J0 = J1
              K0 = J1 - JJ
              DO 10 K = 1, JJ
                   T = T - L(K0)*LIN(J0)
                   J0 = J0 - 1
                   K0 = K0 + K - I
 10                CONTINUE
              LIN(J0) = T/L(K0)
 20           CONTINUE
         J0 = J0 - 1
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LINVRT FOLLOWS  ***
      END
      SUBROUTINE LITVMU(N, X, L, Y)                                     LIT00010
C
C  ***  SOLVE  (L**T)*X = Y,  WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
      INTEGER N
      DOUBLE PRECISION X(N), L(1), Y(N)
      INTEGER I, II, IJ, IM1, I0, J, NP1
      DOUBLE PRECISION XI, ZERO
C/6
      DATA ZERO/0.D+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
      DO 10 I = 1, N
 10      X(I) = Y(I)
      NP1 = N + 1
      I0 = N*(N+1)/2
      DO 30 II = 1, N
         I = NP1 - II
         XI = X(I)/L(I0)
         X(I) = XI
         IF (I .LE. 1) GO TO 999
         I0 = I0 - I
         IF (XI .EQ. ZERO) GO TO 30
         IM1 = I - 1
         DO 20 J = 1, IM1
              IJ = I0 + J
              X(J) = X(J) - XI*L(IJ)
 20           CONTINUE
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LITVMU FOLLOWS  ***
      END
      SUBROUTINE LIVMUL(N, X, L, Y)                                     LIV00010
C
C  ***  SOLVE  L*X = Y, WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
      INTEGER N
      DOUBLE PRECISION X(N), L(1), Y(N)
      EXTERNAL DOTPRD
      DOUBLE PRECISION DOTPRD
      INTEGER I, J, K
      DOUBLE PRECISION T, ZERO
C/6
      DATA ZERO/0.D+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
      DO 10 K = 1, N
         IF (Y(K) .NE. ZERO) GO TO 20
         X(K) = ZERO
 10      CONTINUE
      GO TO 999
 20   J = K*(K+1)/2
      X(K) = Y(K) / L(J)
      IF (K .GE. N) GO TO 999
      K = K + 1
      DO 30 I = K, N
         T = DOTPRD(I-1, L(J+1), X)
         J = J + I
         X(I) = (Y(I) - T)/L(J)
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LIVMUL FOLLOWS  ***
      END
      SUBROUTINE LMSTEP(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W)  LMS00010
C
C  ***  COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE  **
C  ***  NL2SOL VERSION 2.2.  ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER IERR, KA, P
      INTEGER IPIVOT(P)
      DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1)
C     DIMENSION W(P*(P+5)/2 + 4)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C        GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN
C     MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING
C     RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG-
C     MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE-
C     TECHNIQUE.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C      D (IN)  = THE SCALE VECTOR.
C      G (IN)  = THE GRADIENT VECTOR (J**T)*R.
C   IERR (I/O) = RETURN CODE FROM QRFACT OR QRFGS -- 0 MEANS R HAS
C             FULL RANK.
C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR QRFGS, WHICH COMPUTE
C             QR DECOMPOSITIONS WITH COLUMN PIVOTING.
C     KA (I/O).  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON
C             LMSTEP FOR THE CURRENT R AND QTR.  ON OUTPUT KA CON-
C             TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE
C             STEP.  KA = 0 MEANS A GAUSS-NEWTON STEP.
C      P (IN)  = NUMBER OF PARAMETERS.
C    QTR (IN)  = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR.
C      R (IN)  = THE R MATRIX, STORED COMPACTLY BY COLUMNS.
C   STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED.
C      V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C      W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4.
C
C  ***  ENTRIES IN V  ***
C
C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
C V(DSTNRM) (I/O) = 2-NORM OF D*STEP.
C V(DST0)   (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J).
C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS
C             TWONORM(R - J*STEP)**2.  (SEE ALGORITHM NOTES BELOW.)
C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
C             FOR A GAUSS-NEWTON STEP.
C V(PHMNFC) (IN)  = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
C             BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
C V(PHMXFC) (IN)  (SEE V(PHMNFC).)
C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
C             BY THE STEP RETURNED.
C V(RADIUS) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(RAD0)   (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL
C             CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS).
C
C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS.
C
C  ***  USAGE NOTES  ***
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS).  (THIS EXPLAINS
C     WHY MANY PARAMETERS ARE LISTED AS I/O).  ON AN INTIIAL CALL (ONE
C     WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P,
C     QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0).
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
C     SQUARES) PACKAGE (REF. 1).
C
C  ***  ALGORITHM NOTES  ***
C
C     THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN
C     REFS. 2 AND 4.  FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60-
C     62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER.
C        A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS)
C     IS SUFFICIENTLY LARGE.  IN THIS CASE THE STEP RETURNED IS SUCH
C     THAT  TWONORM(R)**2 - TWONORM(R - J*STEP)**2  DIFFERS FROM ITS
C     OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE,
C     WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL.  (SEE
C     REF. 2 FOR MORE DETAILS.)
C
C  ***  FUNCTIONS AND SUBROUTINES CALLED  ***
C
C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS.
C LITVMU - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C VCOPY  - COPIES ONE VECTOR TO ANOTHER.
C V2NORM - RETURNS 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C 2.  GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
C             SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
C             186-197.
C 3.  LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES
C             PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J.
C 4.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN,
     1        PP1O2, RES, RES0, RMAT, RMAT0, UK0
      DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2,
     1                 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
     2                 SI, SJ, SQRTAK, T, TWOPSI, UK, WL
C
C     ***  CONSTANTS  ***
      DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE,
     1                 TTOL, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER IABS
      DOUBLE PRECISION DABS, DMAX1, DMIN1, DSQRT
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DOTPRD, LITVMU, LIVMUL, VCOPY, V2NORM
      DOUBLE PRECISION DOTPRD, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
      INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
     1        PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
C/6
      DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/,
     1     GTSTEP/4/, NREDUC/6/, PHMNFC/20/,
     2     PHMXFC/21/, PREDUC/7/, RADIUS/8/,
     3     RAD0/9/, STPPAR/5/
C/7
C     PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19,
C    1     GTSTEP=4, NREDUC=6, PHMNFC=20,
C    2     PHMXFC=21, PREDUC=7, RADIUS=8,
C    3     RAD0=9, STPPAR=5)
C/
C
C/6
      DATA DFAC/256.D+0/, EIGHT/8.D+0/, HALF/0.5D+0/, NEGONE/-1.D+0/,
     1     ONE/1.D+0/, P001/1.D-3/, THREE/3.D+0/, TTOL/2.5D+0/,
     2     ZERO/0.D+0/
C/7
C     PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0,
C    1     ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0,
C    2     ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
C     ***  FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK,
C     ***  THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J)
C     ***  AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0),
C     ***  W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY.
      LK0 = P + 1
      PHIPIN = LK0 + 1
      UK0 = PHIPIN + 1
      DSTSAV = UK0 + 1
      RMAT0 = DSTSAV
C     ***  A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS
C     ***  STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL
C     ***  VECTOR IS STORED IN W STARTING AT W(RES).  THE LOOPS BELOW
C     ***  THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER
C     ***  WORK ON THESE COPIES.
      RMAT = RMAT0 + 1
      PP1O2 = P * (P + 1) / 2
      RES0 = PP1O2 + RMAT0
      RES = RES0 + 1
      RAD = V(RADIUS)
      IF (RAD .GT. ZERO)
     1   PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2)
      PHIMAX = V(PHMXFC) * RAD
      PHIMIN = V(PHMNFC) * RAD
C     ***  DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS
C     ***  REPRESENTATION OF THE UPDATED QR DECOMPOSITION.
      DTOL = ONE/DFAC
      DFACSQ = DFAC*DFAC
C     ***  OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY.  IF
C     ***  WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
      OLDPHI = ZERO
      LK = ZERO
      UK = ZERO
      KALIM = KA + 12
C
C  ***  START OR RESTART, DEPENDING ON KA  ***
C
      IF (KA) 10, 20, 370
C
C  ***  FRESH START -- COMPUTE V(NREDUC)  ***
C
 10   KA = 0
      KALIM = 12
      K = P
      IF (IERR .NE. 0) K = IABS(IERR) - 1
      V(NREDUC) = HALF*DOTPRD(K, QTR, QTR)
C
C  ***  SET UP TO TRY INITIAL GAUSS-NEWTON STEP  ***
C
 20   V(DST0) = NEGONE
      IF (IERR .NE. 0) GO TO 90
C
C  ***  COMPUTE GAUSS-NEWTON STEP  ***
C
C     ***  NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN
C     ***  R(1), R(2), R(3), ...  IT IS THE TRANSPOSE OF A
C     ***  LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE
C     ***  TREAT IT AS SUCH WHEN USING LITVMU AND LIVMUL.
      CALL LITVMU(P, W, R, QTR)
C     ***  TEMPORARILY STORE PERMUTED -D*STEP IN STEP.
      DO 60 I = 1, P
         J1 = IPIVOT(I)
         STEP(I) = D(J1)*W(I)
 60      CONTINUE
      DST = V2NORM(P, STEP)
      V(DST0) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GO TO 410
C     ***  IF THIS IS A RESTART, GO TO 110  ***
      IF (KA .GT. 0) GO TO 110
C
C  ***  GAUSS-NEWTON STEP WAS UNACCEPTABLE.  COMPUTE L0  ***
C
      DO 70 I = 1, P
         J1 = IPIVOT(I)
         STEP(I) = D(J1)*(STEP(I)/DST)
 70      CONTINUE
      CALL LIVMUL(P, STEP, R, STEP)
      T = ONE / V2NORM(P, STEP)
      W(PHIPIN) = (T/DST)*T
      LK = PHI*W(PHIPIN)
C
C  ***  COMPUTE U0  ***
C
 90   DO 100 I = 1, P
 100     W(I) = G(I)/D(I)
      V(DGNORM) = V2NORM(P, W)
      UK = V(DGNORM)/RAD
      IF (UK .LE. ZERO) GO TO 390
C
C     ***  ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER.  WE
C     ***  USE MORE*S SCHEME FOR INITIALIZING IT.
      ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD
C
C
C  ***  TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES  ***
C
 110  KA = KA + 1
      CALL VCOPY(PP1O2, W(RMAT), R)
      CALL VCOPY(P, W(RES), QTR)
C
C  ***  SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR.  ***
C
      IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     1             ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK))
      SQRTAK = DSQRT(ALPHAK)
      DO 120 I = 1, P
 120     W(I) = ONE
C
C  ***  ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS.  ***
C
      DO 270 I = 1, P
C        ***  GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D.
C        ***  (USE STEP TO STORE TEMPORARY ROW)  ***
         L = I*(I+1)/2 + RMAT0
         WL = W(L)
         D2 = ONE
         D1 = W(I)
         J1 = IPIVOT(I)
         ADI = SQRTAK*D(J1)
         IF (ADI .GE. DABS(WL)) GO TO 150
 130     A = ADI/WL
         B = D2*A/D1
         T = A*B + ONE
         IF (T .GT. TTOL) GO TO 150
         W(I) = D1/T
         D2 = D2/T
         W(L) = T*WL
         A = -A
         DO 140 J1 = I, P
              L = L + J1
              STEP(J1) = A*W(L)
 140          CONTINUE
         GO TO 170
C
 150     B = WL/ADI
         A = D1*B/D2
         T = A*B + ONE
         IF (T .GT. TTOL) GO TO 130
         W(I) = D2/T
         D2 = D1/T
         W(L) = T*ADI
         DO 160 J1 = I, P
              L = L + J1
              WL = W(L)
              STEP(J1) = -WL
              W(L) = A*WL
 160          CONTINUE
C
 170     IF (I .EQ. P) GO TO 280
C
C        ***  NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW  ***
C
         IP1 = I + 1
         DO 260 I1 = IP1, P
              L = I1*(I1+1)/2 + RMAT0
              WL = W(L)
              SI = STEP(I1-1)
              D1 = W(I1)
C
C             ***  RESCALE ROW I1 IF NECESSARY  ***
C
              IF (D1 .GE. DTOL) GO TO 190
                   D1 = D1*DFACSQ
                   WL = WL/DFAC
                   K = L
                   DO 180 J1 = I1, P
                        K = K + J1
                        W(K) = W(K)/DFAC
 180                    CONTINUE
C
C             ***  USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW
C
 190          IF (DABS(SI) .GT. DABS(WL)) GO TO 220
              IF (SI .EQ. ZERO) GO TO 260
 200          A = SI/WL
              B = D2*A/D1
              T = A*B + ONE
              IF (T .GT. TTOL) GO TO 220
              W(L) = T*WL
              W(I1) = D1/T
              D2 = D2/T
              DO 210 J1 = I1, P
                   L = L + J1
                   WL = W(L)
                   SJ = STEP(J1)
                   W(L) = WL + B*SJ
                   STEP(J1) = SJ - A*WL
 210               CONTINUE
              GO TO 240
C
 220          B = WL/SI
              A = D1*B/D2
              T = A*B + ONE
              IF (T .GT. TTOL) GO TO 200
              W(I1) = D2/T
              D2 = D1/T
              W(L) = T*SI
              DO 230 J1 = I1, P
                   L = L + J1
                   WL = W(L)
                   SJ = STEP(J1)
                   W(L) = A*WL + SJ
                   STEP(J1) = B*SJ - WL
 230               CONTINUE
C
C             ***  RESCALE TEMP. ROW IF NECESSARY  ***
C
 240          IF (D2 .GE. DTOL) GO TO 260
                   D2 = D2*DFACSQ
                   DO 250 K = I1, P
 250                    STEP(K) = STEP(K)/DFAC
 260          CONTINUE
 270     CONTINUE
C
C  ***  COMPUTE STEP  ***
C
 280  CALL LITVMU(P, W(RES), W(RMAT), W(RES))
C     ***  RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES)  ***
      DO 290 I = 1, P
         J1 = IPIVOT(I)
         K = RES0 + I
         T = W(K)
         STEP(J1) = -T
         W(K) = T*D(J1)
 290     CONTINUE
      DST = V2NORM(P, W(RES))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430
      IF (OLDPHI .EQ. PHI) GO TO 430
      OLDPHI = PHI
C
C  ***  CHECK FOR (AND HANDLE) SPECIAL CASE  ***
C
      IF (PHI .GT. ZERO) GO TO 310
         IF (KA .GE. KALIM) GO TO 430
              TWOPSI = ALPHAK*DST*DST - DOTPRD(P, STEP, G)
              IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310
                   V(STPPAR) = -ALPHAK
                   GO TO 440
C
C  ***  UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN  ***
C
 300  IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK)
      GO TO 320
 310  IF (PHI .LT. ZERO) UK = ALPHAK
 320  DO 330 I = 1, P
         J1 = IPIVOT(I)
         K = RES0 + I
         STEP(I) = D(J1) * (W(K)/DST)
 330     CONTINUE
      CALL LIVMUL(P, STEP, W(RMAT), STEP)
      DO 340 I = 1, P
 340     STEP(I) = STEP(I) / DSQRT(W(I))
      T = ONE / V2NORM(P, STEP)
      ALPHAK = ALPHAK + T*PHI*T/RAD
      LK = DMAX1(LK, ALPHAK)
      GO TO 110
C
C  ***  RESTART  ***
C
 370  LK = W(LK0)
      UK = W(UK0)
      IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20
      ALPHAK = DABS(V(STPPAR))
      DST = W(DSTSAV)
      PHI = DST - RAD
      T = V(DGNORM)/RAD
      IF (RAD .GT. V(RAD0)) GO TO 380
C
C        ***  SMALLER RADIUS  ***
         UK = T
         IF (ALPHAK .LE. ZERO) LK = ZERO
         IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
         GO TO 300
C
C     ***  BIGGER RADIUS  ***
 380  IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T
      LK = ZERO
      IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
      GO TO 300
C
C  ***  SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR)  ***
C
 390  V(STPPAR) = ZERO
      DST = ZERO
      LK = ZERO
      UK = ZERO
      V(GTSTEP) = ZERO
      V(PREDUC) = ZERO
      DO 400 I = 1, P
 400     STEP(I) = ZERO
      GO TO 450
C
C  ***  ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W  ***
C
 410  ALPHAK = ZERO
      DO 420 I = 1, P
         J1 = IPIVOT(I)
         STEP(J1) = -W(I)
 420     CONTINUE
C
C  ***  SAVE VALUES FOR USE IN A POSSIBLE RESTART  ***
C
 430  V(STPPAR) = ALPHAK
 440  V(GTSTEP) = DOTPRD(P, STEP, G)
      V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP))
 450  V(DSTNRM) = DST
      W(DSTSAV) = DST
      W(LK0) = LK
      W(UK0) = UK
      V(RAD0) = RAD
C
 999  RETURN
C
C  ***  LAST CARD OF LMSTEP FOLLOWS  ***
      END
      SUBROUTINE LSQRT(N1, N, L, A, IRC)                                LSQ00010
C
C  ***  COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR  L  OF
C  ***  A = L*(L**T),  WHERE  L  AND THE LOWER TRIANGLE OF  A  ARE BOTH
C  ***  STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
C  ***  IRC = 0 MEANS ALL WENT WELL.  IRC = J MEANS THE LEADING
C  ***  PRINCIPAL  J X J  SUBMATRIX OF  A  IS NOT POSITIVE DEFINITE --
C  ***  AND  L(J*(J+1)/2)  CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
C
C  ***  PARAMETERS  ***
C
      INTEGER N1, N, IRC
      DOUBLE PRECISION L(1), A(1)
C     DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
      DOUBLE PRECISION T, TD, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      DOUBLE PRECISION DSQRT
C/
C/6
      DATA ZERO/0.D+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
      I0 = N1 * (N1 - 1) / 2
      DO 50 I = N1, N
         TD = ZERO
         IF (I .EQ. 1) GO TO 40
         J0 = 0
         IM1 = I - 1
         DO 30 J = 1, IM1
              T = ZERO
              IF (J .EQ. 1) GO TO 20
              JM1 = J - 1
              DO 10 K = 1, JM1
                   IK = I0 + K
                   JK = J0 + K
                   T = T + L(IK)*L(JK)
 10                CONTINUE
 20           IJ = I0 + J
              J0 = J0 + J
              T = (A(IJ) - T) / L(J0)
              L(IJ) = T
              TD = TD + T*T
 30           CONTINUE
 40      I0 = I0 + I
         T = A(I0) - TD
         IF (T .LE. ZERO) GO TO 60
         L(I0) = DSQRT(T)
 50      CONTINUE
C
      IRC = 0
      GO TO 999
C
 60   L(I0) = T
      IRC = I
C
 999  RETURN
C
C  ***  LAST CARD OF LSQRT  ***
      END
      DOUBLE PRECISION FUNCTION LSVMIN(P, L, X, Y)                      LSV00010
C
C  ***  ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      DOUBLE PRECISION L(1), X(P), Y(P)
C     DIMENSION L(P*(P+1)/2)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C     THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST
C     SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C  P (IN)  = THE ORDER OF L.  L IS A  P X P  LOWER TRIANGULAR MATRIX.
C  L (IN)  = ARRAY HOLDING THE ELEMENTS OF  L  IN ROW ORDER, I.E.
C             L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
C  X (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
C             APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
C             SMALLEST SINGULAR VALUE.  THIS APPROXIMATION MAY BE VERY
C             CRUDE.  IF LSVMIN RETURNS ZERO, THEN SOME COMPONENTS OF X
C             ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
C  Y (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
C             UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
C             ING TO THE SMALLEST SINGULAR VALUE.  THIS APPROXIMATION
C             MAY BE CRUDE.  IF LSVMIN RETURNS ZERO, THEN Y RETAINS ITS
C             INPUT VALUE.  THE CALLER MAY PASS THE SAME VECTOR FOR X
C             AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
C             WRITES X (FOR NONZERO LSVMIN RETURNS).
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THERE ARE NO USAGE RESTRICTIONS.
C
C  ***  ALGORITHM NOTES  ***
C
C     THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
C     LSVMIN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
C     (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
C     LARGEST.  THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
C     IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
C     (2) AND (3).
C
C  ***  SUBROUTINES AND FUNCTIONS CALLED  ***
C
C        V2NORM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C     (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
C         AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
C         TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
C
C     (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
C         RANDOM-NUMBER GENERATORS --  AN EMPIRICAL VIEW,
C         MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
C
C     (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
C         (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
C
C     (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
C         GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
C         PP. 586-593.
C
C  ***  HISTORY  ***
C
C     DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PPLUS1
      DOUBLE PRECISION B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS
C
C  ***  CONSTANTS  ***
C
      DOUBLE PRECISION HALF, ONE, R9973, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER MOD
      REAL FLOAT
      DOUBLE PRECISION DABS
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL V2NORM
      DOUBLE PRECISION V2NORM
C
C/6
      DATA HALF/0.5D+0/, ONE/1.D+0/, R9973/9973.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
C     SAVE IX
C/
      DATA IX/2/
C
C  ***  BODY  ***
C
C  ***  FIRST CHECK WHETHER TO RETURN LSVMIN = 0 AND INITIALIZE X  ***
C
      II = 0
      DO 10 I = 1, P
         X(I) = ZERO
         II = II + I
         IF (L(II) .EQ. ZERO) GO TO 300
 10      CONTINUE
      IF (MOD(IX, 9973) .EQ. 0) IX = 2
      PPLUS1 = P + 1
C
C  ***  SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
C  ***  CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
C
C     DO J = P TO 1 BY -1...
      DO 100 JJJ = 1, P
         J = PPLUS1 - JJJ
C       ***  DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
C       ***  THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
         IX = MOD(3432*IX, 9973)
         B = HALF*(ONE + FLOAT(IX)/R9973)
         XPLUS = (B - X(J))
         XMINUS = (-B - X(J))
         SPLUS = DABS(XPLUS)
         SMINUS = DABS(XMINUS)
         JM1 = J - 1
         J0 = J*JM1/2
         JJ = J0 + J
         XPLUS = XPLUS/L(JJ)
         XMINUS = XMINUS/L(JJ)
         IF (JM1 .EQ. 0) GO TO 30
         DO 20 I = 1, JM1
              JI = J0 + I
              SPLUS = SPLUS + DABS(X(I) + L(JI)*XPLUS)
              SMINUS = SMINUS + DABS(X(I) + L(JI)*XMINUS)
 20           CONTINUE
 30      IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
         X(J) = XPLUS
C       ***  UPDATE PARTIAL SUMS  ***
         IF (JM1 .EQ. 0) GO TO 100
         DO 40 I = 1, JM1
              JI = J0 + I
              X(I) = X(I) + L(JI)*XPLUS
 40           CONTINUE
 100     CONTINUE
C
C  ***  NORMALIZE X  ***
C
      T = ONE/V2NORM(P, X)
      DO 110 I = 1, P
 110     X(I) = T*X(I)
C
C  ***  SOLVE L*Y = X AND RETURN SVMIN = 1/TWONORM(Y)  ***
C
      DO 200 J = 1, P
         PSJ = ZERO
         JM1 = J - 1
         J0 = J*JM1/2
         IF (JM1 .EQ. 0) GO TO 130
         DO 120 I = 1, JM1
              JI = J0 + I
              PSJ = PSJ + L(JI)*Y(I)
 120          CONTINUE
 130     JJ = J0 + J
         Y(J) = (X(J) - PSJ)/L(JJ)
 200     CONTINUE
C
      LSVMIN = ONE/V2NORM(P, Y)
      GO TO 999
C
 300  LSVMIN = ZERO
 999  RETURN
C  ***  LAST CARD OF LSVMIN FOLLOWS  ***
      END
      SUBROUTINE LTSQAR(N, A, L)                                        LTS00010
C
C  ***  SET A TO LOWER TRIANGLE OF (L**T) * L  ***
C
C  ***  L = N X N LOWER TRIANG. MATRIX STORED ROWWISE.  ***
C  ***  A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L.  ***
C
      INTEGER N
      DOUBLE PRECISION A(1), L(1)
C     DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
C
      INTEGER I, II, IIM1, I1, J, K, M
      DOUBLE PRECISION LII, LJ
C
      II = 0
      DO 50 I = 1, N
         I1 = II + 1
         II = II + I
         M = 1
         IF (I .EQ. 1) GO TO 30
         IIM1 = II - 1
         DO 20 J = I1, IIM1
              LJ = L(J)
              DO 10 K = I1, J
                   A(M) = A(M) + LJ*L(K)
                   M = M + 1
 10                CONTINUE
 20           CONTINUE
 30      LII = L(II)
         DO 40 J = I1, II
 40           A(J) = LII * L(J)
 50      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF LTSQAR FOLLOWS  ***
      END
      SUBROUTINE PARCHK(IV, N, NN, P, V)                                PAR00010
C
C  ***  CHECK NL2SOL (VERSION 2.2) PARAMETERS, PRINT CHANGED VALUES  ***
C
      INTEGER IV(1), N, NN, P
      DOUBLE PRECISION V(1)
C     DIMENSION IV(*), V(*)
C
      EXTERNAL DFAULT, RMDCON, VCOPY
      DOUBLE PRECISION RMDCON
C DFAULT -- SUPPLIES DFAULT PARAMETER VALUES.
C RMDCON -- RETURNS MACHINE-DEPENDENT CONSTANTS.
C VCOPY  -- COPIES ONE VECTOR TO ANOTHER.
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IV1, JTOLP, K, L, M, NVDFLT, PU
C/6
      REAL CNGD(3), DFLT(3), VN(2,27), WHICH(3)
C/7
C     CHARACTER*4 CNGD(3), DFLT(3), VN(2,27), WHICH(3)
C/
      DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(27), VX(27), ZERO
C
C  ***  IV AND V SUBSCRIPTS  ***
C
      INTEGER DTYPE, DTYPE0, D0INIT, EPSLON, INITS, JTINIT, JTOL0,
     1        JTOL1, OLDN, OLDNN, OLDP, PARPRT, PARSV1, PRUNIT
C
C/6
      DATA NVDFLT/27/, ZERO/0.D+0/
C/7
C     PARAMETER (NVDFLT=27, ZERO=0.D+0)
C/
C
C/6
      DATA DTYPE/16/, DTYPE0/29/, D0INIT/37/, EPSLON/19/,
     1     INITS/25/, JTINIT/39/, JTOL0/86/, JTOL1/87/,
     2     OLDN/45/, OLDNN/46/, OLDP/47/, PARPRT/20/,
     3     PARSV1/51/, PRUNIT/21/
C/7
C     PARAMETER (DTYPE=16, DTYPE0=29, D0INIT=37, EPSLON=19,
C    1     INITS=25, JTINIT=39, JTOL0=86, JTOL1=87,
C    2     OLDN=45, OLDNN=46, OLDP=47, PARPRT=20,
C    3     PARSV1=51, PRUNIT=21)
C     SAVE BIG, TINY
C/
C
      DATA BIG/0.D+0/, TINY/1.D+0/
C/6
      DATA VN(1,1),VN(2,1)/4HEPSL,4HON../
      DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../
      DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../
      DATA VN(1,4),VN(2,4)/4HDECF,4HAC../
      DATA VN(1,5),VN(2,5)/4HINCF,4HAC../
      DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../
      DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../
      DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../
      DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../
      DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../
      DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../
      DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../
      DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../
      DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../
      DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../
      DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../
      DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../
      DATA VN(1,18),VN(2,18)/4HDLTF,4HDJ../
      DATA VN(1,19),VN(2,19)/4HD0IN,4HIT../
      DATA VN(1,20),VN(2,20)/4HDINI,4HT.../
      DATA VN(1,21),VN(2,21)/4HJTIN,4HIT../
      DATA VN(1,22),VN(2,22)/4HDLTF,4HDC../
      DATA VN(1,23),VN(2,23)/4HDFAC,4H..../
      DATA VN(1,24),VN(2,24)/4HRLIM,4HIT../
      DATA VN(1,25),VN(2,25)/4HCOSM,4HIN../
      DATA VN(1,26),VN(2,26)/4HDELT,4HA0../
      DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../
C/7
C     DATA VN(1,1),VN(2,1)/'EPSL','ON..'/
C     DATA VN(1,2),VN(2,2)/'PHMN','FC..'/
C     DATA VN(1,3),VN(2,3)/'PHMX','FC..'/
C     DATA VN(1,4),VN(2,4)/'DECF','AC..'/
C     DATA VN(1,5),VN(2,5)/'INCF','AC..'/
C     DATA VN(1,6),VN(2,6)/'RDFC','MN..'/
C     DATA VN(1,7),VN(2,7)/'RDFC','MX..'/
C     DATA VN(1,8),VN(2,8)/'TUNE','R1..'/
C     DATA VN(1,9),VN(2,9)/'TUNE','R2..'/
C     DATA VN(1,10),VN(2,10)/'TUNE','R3..'/
C     DATA VN(1,11),VN(2,11)/'TUNE','R4..'/
C     DATA VN(1,12),VN(2,12)/'TUNE','R5..'/
C     DATA VN(1,13),VN(2,13)/'AFCT','OL..'/
C     DATA VN(1,14),VN(2,14)/'RFCT','OL..'/
C     DATA VN(1,15),VN(2,15)/'XCTO','L...'/
C     DATA VN(1,16),VN(2,16)/'XFTO','L...'/
C     DATA VN(1,17),VN(2,17)/'LMAX','0...'/
C     DATA VN(1,18),VN(2,18)/'DLTF','DJ..'/
C     DATA VN(1,19),VN(2,19)/'D0IN','IT..'/
C     DATA VN(1,20),VN(2,20)/'DINI','T...'/
C     DATA VN(1,21),VN(2,21)/'JTIN','IT..'/
C     DATA VN(1,22),VN(2,22)/'DLTF','DC..'/
C     DATA VN(1,23),VN(2,23)/'DFAC','....'/
C     DATA VN(1,24),VN(2,24)/'RLIM','IT..'/
C     DATA VN(1,25),VN(2,25)/'COSM','IN..'/
C     DATA VN(1,26),VN(2,26)/'DELT','A0..'/
C     DATA VN(1,27),VN(2,27)/'FUZZ','....'/
C/
C
      DATA VM(1)/1.0D-3/, VM(2)/-0.99D+0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/,
     1     VM(5)/1.2D+0/, VM(6)/1.D-2/, VM(7)/1.2D+0/, VM(8)/0.D+0/,
     2     VM(9)/0.D+0/, VM(10)/1.D-3/, VM(11)/-1.D+0/, VM(15)/0.D+0/,
     3     VM(16)/0.D+0/, VM(19)/0.D+0/, VM(20)/-10.D+0/, VM(21)/0.D+0/,
     4     VM(23)/0.D+0/, VM(24)/1.D+10/, VM(27)/1.01D+0/
      DATA VX(1)/0.9D+0/, VX(2)/-1.D-3/, VX(3)/1.D+1/, VX(4)/0.8D+0/,
     1     VX(5)/1.D+2/, VX(6)/0.8D+0/, VX(7)/1.D+2/, VX(8)/0.5D+0/,
     2     VX(9)/0.5D+0/, VX(10)/1.D+0/, VX(11)/1.D+0/, VX(14)/0.1D+0/,
     3     VX(15)/1.D+0/, VX(16)/1.D+0/, VX(18)/1.D+0/, VX(22)/1.D+0/,
     4     VX(23)/1.D+0/, VX(25)/1.D+0/, VX(26)/1.D+0/, VX(27)/1.D+2/
C
C/6
      DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/,
     1     DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/
C/7
C     DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/,
C    1     DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/
C/
C
C.......................................................................
C
      IF (IV(1) .EQ. 0) CALL DFAULT(IV, V)
      PU = IV(PRUNIT)
      IV1 = IV(1)
      IF (IV1 .NE. 12) GO TO 30
         IF (NN .GE. N .AND. N .GE. P .AND. P .GE. 1) GO TO 20
              IV(1) = 16
              IF (PU .NE. 0) WRITE(PU,10) NN, N, P
 10           FORMAT(30H0///// BAD NN, N, OR P... NN =,I5,5H, N =,I5,
     1               5H, P =,I5)
              GO TO 999
 20      K = IV(21)
         CALL DFAULT(IV(21), V(33))
         IV(21) = K
         IV(DTYPE0) = IV(DTYPE+20)
         IV(OLDN) = N
         IV(OLDNN) = NN
         IV(OLDP) = P
         WHICH(1) = DFLT(1)
         WHICH(2) = DFLT(2)
         WHICH(3) = DFLT(3)
         GO TO 80
 30   IF (N .EQ. IV(OLDN) .AND. NN .EQ. IV(OLDNN) .AND. P .EQ. IV(OLDP))
     1                       GO TO 50
         IV(1) = 17
         IF (PU .NE. 0) WRITE(PU,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN,
     1                               N, P
 40      FORMAT(30H0///// (NN,N,P) CHANGED FROM (,I5,1H,,I5,1H,,I3,
     1          6H) TO (,I5,1H,,I5,1H,,I3,2H).)
         GO TO 999
C
 50   IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70
         IV(1) = 50
         IF (PU .NE. 0) WRITE(PU,60) IV1
 60      FORMAT(15H0/////  IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 12.)
         GO TO 999
C
 70   WHICH(1) = CNGD(1)
      WHICH(2) = CNGD(2)
      WHICH(3) = CNGD(3)
C
 80   IF (BIG .GT. TINY) GO TO 90
         TINY = RMDCON(1)
         MACHEP = RMDCON(3)
         BIG = RMDCON(6)
         VM(12) = MACHEP
         VX(12) = BIG
         VM(13) = TINY
         VX(13) = BIG
         VM(14) = MACHEP
         VM(17) = TINY
         VX(17) = BIG
         VM(18) = MACHEP
         VX(19) = BIG
         VX(20) = BIG
         VX(21) = BIG
         VM(22) = MACHEP
         VX(24) = RMDCON(5)
         VM(25) = MACHEP
         VM(26) = MACHEP
 90   M = 0
      IF (IV(INITS) .GE. 0 .AND. IV(INITS) .LE. 2) GO TO 110
         M = 18
         IF (PU .NE. 0) WRITE(PU,100) IV(INITS)
 100     FORMAT(25H0/////  INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0,
     1          7H AND 2.)
 110  K = EPSLON
      DO 140 I = 1, NVDFLT
         VK = V(K)
         IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 130
              M = K
              IF (PU .NE. 0) WRITE(PU,120) VN(1,I), VN(2,I), K, VK,
     1                                    VM(I), VX(I)
 120          FORMAT(8H0/////  ,2A4,5H.. V(,I2,3H) =,D11.3,7H SHOULD,
     1               11H BE BETWEEN,D11.3,4H AND,D11.3)
 130     K = K + 1
 140     CONTINUE
C
      IF (IV1 .EQ. 12 .AND. V(JTINIT) .GT. ZERO) GO TO 170
C
C  ***  CHECK JTOL VALUES  ***
C
      JTOLP = JTOL0 + P
      DO 160 I = JTOL1, JTOLP
         IF (V(I) .GT. ZERO) GO TO 160
         K = I - JTOL0
         IF (PU .NE. 0) WRITE(PU,150) K, I, V(I)
 150     FORMAT(12H0///// JTOL(,I3,6H) = V(,I3,3H) =,D11.3,
     1          20H SHOULD BE POSITIVE.)
         M = I
 160     CONTINUE
C
 170  IF (M .EQ. 0) GO TO 180
         IV(1) = M
         GO TO 999
C
 180  IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999
      IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. 0) GO TO 200
         M = 1
         WRITE(PU,190) IV(INITS)
 190     FORMAT(22H0NONDEFAULT VALUES..../20H INITS..... IV(25) =,I3)
 200  IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO  210
         IF (M .EQ. 0) WRITE(PU,215) WHICH
         M = 1
         WRITE(PU,205) IV(DTYPE)
 205     FORMAT(20H DTYPE..... IV(16) =,I3)
 210  K = EPSLON
      L = PARSV1
      DO 240 I = 1, NVDFLT
         IF (V(K) .EQ. V(L)) GO TO 230
              IF (M .EQ. 0) WRITE(PU,215) WHICH
 215          FORMAT(1H0,3A4,9HALUES..../)
              M = 1
              WRITE(PU,220) VN(1,I), VN(2,I), K, V(K)
 220          FORMAT(1X,2A4,5H.. V(,I2,3H) =,D15.7)
 230     K = K + 1
         L = L + 1
 240     CONTINUE
      IV(DTYPE0) = IV(DTYPE)
      CALL VCOPY(NVDFLT, V(PARSV1), V(EPSLON))
      IF (IV1 .NE. 12) GO TO 999
         IF (V(JTINIT) .GT. ZERO) GO TO 260
              JTOLP = JTOL0 + P
              WRITE(PU,250) (V(I), I = JTOL1, JTOLP)
 250          FORMAT(24H0(INITIAL) JTOL ARRAY.../(1X,6D12.3))
 260     IF (V(D0INIT) .GT. ZERO) GO TO 999
              K = JTOL1 + P
              L = K + P - 1
              WRITE(PU,270) (V(I), I = K, L)
 270          FORMAT(22H0(INITIAL) D0 ARRAY.../1X,6D12.3)
C
 999  RETURN
C  ***  LAST CARD OF PARCHK FOLLOWS  ***
      END
      SUBROUTINE QAPPLY(NN, N, P, J, R, IERR)                           QAP00010
C     *****PARAMETERS.
      INTEGER NN, N, P, IERR
      DOUBLE PRECISION J(NN,P), R(N)
C
C     ..................................................................
C     ..................................................................
C
C     *****PURPOSE.
C     THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS
C     STORED IN J BY QRFACT
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN
C             THE CALLING PROGRAM DIMENSION STATEMENT
C
C        N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R
C
C        P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA
C
C        J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS
C             U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
C             IDENT - U*U.TRANSPOSE
C
C        R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL
C             TRANSFORMATIONS WILL BE APPLIED
C
C        IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS
C             WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST
C             ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED
C
C     ON OUTPUT.
C
C        R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     NONE
C
C     *****ALGORITHM NOTES.
C     THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
C     ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2.  THE USE OF
C     THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1).
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C
C     DOTPRD - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS
C
C     *****REFERENCES.
C     (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES
C        SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7,
C        PP. 269-276.
C
C     *****HISTORY.
C     DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977)
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C     *****LOCAL VARIABLES.
      INTEGER I, K, L, NL1
      DOUBLE PRECISION T
C     *****INTRINSIC FUNCTIONS.
C/+
      INTEGER IABS
C/
C     *****FUNCTIONS.
      EXTERNAL DOTPRD
      DOUBLE PRECISION DOTPRD
C
      K = P
      IF (IERR .NE. 0) K = IABS(IERR) - 1
      IF ( K .EQ. 0) GO TO 999
C
      DO 20 L = 1, K
         NL1 = N - L + 1
         T = -DOTPRD(NL1, J(L,L), R(L))
C
         DO 10 I = L, N
 10           R(I) = R(I) + T*J(I,L)
 20   CONTINUE
 999  RETURN
C     .... LAST CARD OF QAPPLY .........................................
      END
      SUBROUTINE QRFACT(NM,M,N,QR,ALPHA,IPIVOT,IERR,NOPIVK,SUM)         QRF00010
C
C  ***  COMPUTE THE QR DECOMPOSITION OF THE MATRIX STORED IN QR  ***
C
C     *****PARAMETERS.
      INTEGER NM,M,N,IPIVOT(N),IERR,NOPIVK
      DOUBLE PRECISION  QR(NM,N),ALPHA(N),SUM(N)
C     *****LOCAL VARIABLES.
      INTEGER I,J,JBAR,K,K1,MINUM,MK1
      DOUBLE PRECISION  ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL,
     1        RKTOL1,SUMJ
C     *****FUNCTIONS.
C/+
      INTEGER MIN0
      DOUBLE PRECISION  DABS,DSQRT
C/
      EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM
      DOUBLE PRECISION DOTPRD, RMDCON, V2NORM
C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS.
C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS.
C VAXPY... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C V2NORM... RETURNS THE 2-NORM OF A VECTOR.
C
C     *****CONSTANTS.
      DOUBLE PRECISION ONE, P01, P99, ZERO
C/6
      DATA ONE/1.0D+0/, P01/0.01D+0/, P99/0.99D+0/, ZERO/0.0D+0/
C/7
C     PARAMETER (ONE=1.0D+0, P01=0.01D+0, P99=0.99D+0, ZERO=0.0D+0)
C     SAVE RKTOL, UFETA
C/
C
C
C     ..................................................................
C     ..................................................................
C
C
C     *****PURPOSE.
C
C     THIS SUBROUTINE DOES A QR-DECOMPOSITION ON THE M X N MATRIX QR,
C        WITH AN OPTIONALLY MODIFIED COLUMN PIVOTING, AND RETURNS THE
C        UPPER TRIANGULAR R-MATRIX, AS WELL AS THE ORTHOGONAL VECTORS
C        USED IN THE TRANSFORMATIONS.
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF THE TWO DIMENSIONAL
C             ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C             DIMENSION STATEMENT.
C
C        M MUST BE SET TO THE NUMBER OF ROWS IN THE MATRIX.
C
C        N MUST BE SET TO THE NUMBER OF COLUMNS IN THE MATRIX.
C
C        QR CONTAINS THE REAL RECTANGULAR MATRIX TO BE DECOMPOSED.
C
C     NOPIVK IS USED TO CONTROL PIVOTTING.  COLUMNS 1 THROUGH
C        NOPIVK WILL REMAIN FIXED IN POSITION.
C
C        SUM IS USED FOR TEMPORARY STORAGE FOR THE SUBROUTINE.
C
C     ON OUTPUT.
C
C        QR CONTAINS THE NON-DIAGONAL ELEMENTS OF THE R-MATRIX
C             IN THE STRICT UPPER TRIANGLE. THE VECTORS U, WHICH
C             DEFINE THE HOUSEHOLDER TRANSFORMATIONS   I - U*U-TRANSP,
C             ARE IN THE COLUMNS OF THE LOWER TRIANGLE. THESE VECTORS U
C             ARE SCALED SO THAT THE SQUARE OF THEIR 2-NORM IS 2.0.
C
C        ALPHA CONTAINS THE DIAGONAL ELEMENTS OF THE R-MATRIX.
C
C        IPIVOT REFLECTS THE COLUMN PIVOTING PERFORMED ON THE INPUT
C             MATRIX TO ACCOMPLISH THE DECOMPOSITION. THE J-TH
C             ELEMENT OF IPIVOT GIVES THE COLUMN OF THE ORIGINAL
C             MATRIX WHICH WAS PIVOTED INTO COLUMN J DURING THE
C             DECOMPOSITION.
C
C        IERR IS SET TO.
C             0 FOR NORMAL RETURN,
C             K IF NO NON-ZERO PIVOT COULD BE FOUND FOR THE K-TH
C                  TRANSFORMATION, OR
C             -K FOR AN ERROR EXIT ON THE K-TH THANSFORMATION.
C             IF AN ERROR EXIT WAS TAKEN, THE FIRST (K - 1)
C             TRANSFORMATIONS ARE CORRECT.
C
C
C     *****APPLICATIONS AND USAGE RESTRICTIONS.
C     THIS MAY BE USED WHEN SOLVING LINEAR LEAST-SQUARES PROBLEMS --
C     SEE SUBROUTINE QR1 OF ROSEPACK.  IT IS CALLED FOR THIS PURPOSE
C     BY LLSQST IN THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE.
C
C     *****ALGORITHM NOTES.
C     THIS VERSION OF QRFACT TRIES TO ELIMINATE THE OCCURRENCE OF
C     UNDERFLOWS DURING THE ACCUMULATION OF INNER PRODUCTS.  RKTOL1
C     IS CHOSEN BELOW SO AS TO INSURE THAT DISCARDED TERMS HAVE NO
C     EFFECT ON THE COMPUTED TWO-NORMS.
C
C     ADAPTED FROM THE ALGOL ROUTINE SOLVE (1).
C
C     *****REFERENCES.
C     (1)     BUSINGER,P. AND GOLUB,G.H., LINEAR LEAST SQUARES
C     SOLUTIONS BY HOUSHOLDER TRANSFORMATIONS, IN WILKINSON,J.H.
C     AND REINSCH,C.(EDS.), HANDBOOK FOR AUTOMATIC COMPUTATION,
C     VOLUME II. LINEAR ALGEBRA, SPRINGER-VERLAG, 111-118 (1971).
C     PREPUBLISHED IN NUMER.MATH. 7, 269-276 (1965).
C
C     *****HISTORY.
C     THIS AMOUNTS TO THE SUBROUTINE QR1 OF ROSEPACK WITH RKTOL1 USED
C     IN PLACE OF RKTOL BELOW, WITH V2NORM USED TO INITIALIZE (AND
C     SOMETIMES UPDATE) THE SUM ARRAY, AND WITH CALLS ON DOTPRD AND
C     VAXPY IN PLACE OF SOME LOOPS.
C
C     *****GENERAL.
C
C     DEVELOPMENT OF THIS PROGRAM SUPPORTED IN PART BY
C     NATIONAL SCIENCE FOUNDATION GRANT GJ-1154X3 AND
C     NATIONAL SCIENCE FOUNDATION GRANT DCR75-08802
C     TO NATIONAL BUREAU OF ECONOMIC RESEARCH, INC.
C
C
C
C     ..................................................................
C     ..................................................................
C
C
C     ..........  UFETA IS THE SMALLEST POSITIVE FLOATING POINT NUMBER
C        S.T. UFETA AND -UFETA CAN BOTH BE REPRESENTED.
C
C     ..........  RKTOL IS THE SQUARE ROOT OF THE RELATIVE PRECISION
C        OF FLOATING POINT ARITHMETIC (MACHEP).
      DATA RKTOL/0.D+0/, UFETA/0.D+0/
C     *****BODY OF PROGRAM.
      IF (UFETA .GT. ZERO) GO TO 10
         UFETA = RMDCON(1)
         RKTOL = RMDCON(4)
   10 IERR = 0
      RKTOL1 = P01 * RKTOL
C
      DO 20 J=1,N
         SUM(J) = V2NORM(M, QR(1,J))
         IPIVOT(J) = J
   20 CONTINUE
C
      MINUM = MIN0(M,N)
C
      DO 120 K=1,MINUM
         MK1 = M - K + 1
C        ..........K-TH HOUSEHOLDER TRANSFORMATION..........
         SIGMA = ZERO
         JBAR = 0
C        ..........FIND LARGEST COLUMN SUM..........
      IF (K .LE. NOPIVK) GO TO 50
         DO 30 J=K,N
              IF (SIGMA .GE. SUM(J))  GO TO 30
              SIGMA = SUM(J)
              JBAR = J
   30    CONTINUE
C
         IF (JBAR .EQ. 0)  GO TO 220
         IF (JBAR .EQ. K)  GO TO 50
C        ..........COLUMN INTERCHANGE..........
         I = IPIVOT(K)
         IPIVOT(K) = IPIVOT(JBAR)
         IPIVOT(JBAR) = I
         SUM(JBAR) = SUM(K)
         SUM(K) = SIGMA
C
         DO 40 I=1,M
              SIGMA = QR(I,K)
              QR(I,K) = QR(I,JBAR)
              QR(I,JBAR) = SIGMA
   40    CONTINUE
C        ..........END OF COLUMN INTERCHANGE..........
   50    CONTINUE
C        ..........  SECOND INNER PRODUCT  ..........
         QRKMAX = ZERO
C
         DO 60 I=K,M
              IF (DABS( QR(I,K) ) .GT. QRKMAX)  QRKMAX = DABS( QR(I,K) )
   60    CONTINUE
C
         IF (QRKMAX .LT. UFETA)  GO TO 210
         ALPHAK = V2NORM(MK1, QR(K,K)) / QRKMAX
         SIGMA = ALPHAK**2
C
C        ..........  END SECOND INNER PRODUCT  ..........
         QRKK = QR(K,K)
         IF (QRKK .GE. ZERO)  ALPHAK = -ALPHAK
         ALPHA(K) = ALPHAK * QRKMAX
         BETA = QRKMAX * DSQRT(SIGMA - (QRKK*ALPHAK/QRKMAX) )
         QR(K,K) = QRKK - ALPHA(K)
         DO 65 I=K,M
   65         QR(I,K) =  QR(I,K) / BETA
         K1 = K + 1
         IF (K1 .GT. N) GO TO 120
C
         DO 110 J = K1, N
              TEMP = -DOTPRD(MK1, QR(K,K), QR(K,J))
C
C             ***  SET QR(I,J) = QR(I,J) + TEMP*QR(I,K), I = K,...,M.
C
              CALL VAXPY(MK1, QR(K,J), TEMP, QR(K,K), QR(K,J))
C
              IF (K1 .GT. M) GO TO 110
              SUMJ = SUM(J)
              IF (SUMJ .LT. UFETA) GO TO 110
              TEMP = DABS(QR(K,J)/SUMJ)
              IF (TEMP .LT. RKTOL1) GO TO 110
              IF (TEMP .GE. P99) GO TO 90
                   SUM(J) = SUMJ * DSQRT(ONE - TEMP**2)
                   GO TO 110
   90         SUM(J) = V2NORM(M-K, QR(K1,J))
  110    CONTINUE
C        ..........END OF K-TH HOUSEHOLDER TRANSFORMATION..........
  120 CONTINUE
C
      GO TO 999
C     ..........ERROR EXIT ON K-TH TRANSFORMATION..........
  210 IERR = -K
      GO TO 230
C     ..........NO NON-ZERO ACCEPTABLE PIVOT FOUND..........
  220 IERR = K
  230 DO 240 I = K, N
         ALPHA(I) = ZERO
         IF (I .GT. K) CALL VSCOPY(I-K, QR(K,I), ZERO)
 240     CONTINUE
C     ..........RETURN TO CALLER..........
  999 RETURN
C     ..........LAST CARD OF QRFACT..........
      END
      DOUBLE PRECISION FUNCTION RELDST(P, D, X, X0)                     REL00010
C
C  ***  COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0  ***
C  ***  NL2SOL VERSION 2.2  ***
C
      INTEGER P
      DOUBLE PRECISION D(P), X(P), X0(P)
C/+
      DOUBLE PRECISION DABS
C/
      INTEGER I
      DOUBLE PRECISION EMAX, T, XMAX, ZERO
C/6
      DATA ZERO/0.D+0/
C/7
C     PARAMETER (ZERO=0.D+0)
C/
C
      EMAX = ZERO
      XMAX = ZERO
      DO 10 I = 1, P
         T = DABS(D(I) * (X(I) - X0(I)))
         IF (EMAX .LT. T) EMAX = T
         T = D(I) * (DABS(X(I)) + DABS(X0(I)))
         IF (XMAX .LT. T) XMAX = T
 10      CONTINUE
      RELDST = ZERO
      IF (XMAX .GT. ZERO) RELDST = EMAX / XMAX
 999  RETURN
C  ***  LAST CARD OF RELDST FOLLOWS  ***
      END
      SUBROUTINE RPTMUL(FUNC, IPIVOT, J, NN, P, RD, X, Y, Z)            RPT00010
C
C  ***  FUNC = 1... SET  Y = RMAT * (PERM**T) * X.
C  ***  FUNC = 2... SET  Y = PERM * (RMAT**T) * RMAT * (PERM**T) * X.
C  ***  FUNC = 3... SET  Y = PERM * (RMAT**T) X.
C
C
C  ***  PERM = MATRIX WHOSE I-TH COL. IS THE IPIVOT(I)-TH UNIT VECTOR.
C  ***  RMAT IS THE UPPER TRIANGULAR MATRIX WHOSE STRICT UPPER TRIANGLE
C  ***       IS STORED IN  J  AND WHOSE DIAGONAL IS STORED IN RD.
C  ***  Z IS A SCRATCH VECTOR.
C  ***  X AND Y MAY SHARE STORAGE.
C
      INTEGER FUNC, NN, P
      INTEGER IPIVOT(P)
      DOUBLE PRECISION J(NN,P), RD(P), X(P), Y(P), Z(P)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IM1, K, KM1
      DOUBLE PRECISION ZK
C
C  ***  EXTERNAL FUNCTION  ***
C
      EXTERNAL DOTPRD
      DOUBLE PRECISION DOTPRD
C
C-----------------------------------------------------------------------
C
      IF (FUNC .GT. 2) GO TO 50
C
C  ***  FIRST SET  Z = (PERM**T) * X  ***
C
      DO 10 I = 1, P
         K = IPIVOT(I)
         Z(I) = X(K)
 10      CONTINUE
C
C  ***  NOW SET  Y = RMAT * Z  ***
C
      Y(1) = Z(1) * RD(1)
      IF (P .LE. 1) GO TO 40
      DO 30 K = 2, P
         KM1 = K - 1
         ZK = Z(K)
         DO 20 I = 1, KM1
 20           Y(I) = Y(I) + J(I,K)*ZK
         Y(K) = ZK*RD(K)
 30      CONTINUE
C
 40   IF (FUNC .LE. 1) GO TO 999
      GO TO 70
C
 50   DO 60 I = 1, P
 60      Y(I) = X(I)
C
C  ***  SET  Z = (RMAT**T) * Y  ***
C
 70   Z(1) = Y(1) * RD(1)
      IF (P .EQ. 1) GO TO 90
      DO 80 I = 2, P
         IM1 = I - 1
         Z(I) = Y(I)*RD(I) + DOTPRD(IM1, J(1,I), Y)
 80      CONTINUE
C
C  ***  NOW SET  Y = PERM * Z  ***
C
 90   DO 100 I = 1, P
         K = IPIVOT(I)
         Y(K) = Z(I)
 100     CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF RPTMUL FOLLOWS  ***
      END
      SUBROUTINE SLUPDT(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, SLU00010
     1                  Y)
C
C  ***  UPDATE SYMMETRIC  A  SO THAT  A * STEP = Y  ***
C  ***  (LOWER TRIANGLE OF  A  STORED ROWWISE       ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P),
     1                 WCHMTD(P), WSCALE, Y(P)
C     DIMENSION A(P*(P+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, J, K
      DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI
C
C     ***  CONSTANTS  ***
      DOUBLE PRECISION HALF, ONE, ZERO
C
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      DOUBLE PRECISION DABS, DMIN1
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL DOTPRD, SLVMUL, V2NORM
      DOUBLE PRECISION DOTPRD, V2NORM
C
C/6
      DATA HALF/0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0)
C/
C
C-----------------------------------------------------------------------
C
      SDOTWM = DOTPRD(P, STEP, WCHMTD)
      DENMIN = COSMIN * V2NORM(P,STEP) * V2NORM(P,WCHMTD)
      WSCALE = ONE
      IF (DENMIN .NE. ZERO) WSCALE = DMIN1(ONE, DABS(SDOTWM/DENMIN))
      T = ZERO
      IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM
      DO 10 I = 1, P
 10      W(I) = T * WCHMTD(I)
      CALL SLVMUL(P, U, A, STEP)
      T = HALF * (SIZE * DOTPRD(P, STEP, U)  -  DOTPRD(P, STEP, Y))
      DO 20 I = 1, P
 20      U(I) = T*W(I) + Y(I) - SIZE*U(I)
C
C  ***  SET  A = A + U*(W**T) + W*(U**T)  ***
C
      K = 1
      DO 40 I = 1, P
         UI = U(I)
         WI = W(I)
         DO 30 J = 1, I
              A(K) = SIZE*A(K) + UI*W(J) + WI*U(J)
              K = K + 1
 30           CONTINUE
 40      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF SLUPDT FOLLOWS  ***
      END
      SUBROUTINE SLVMUL(P, Y, S, X)                                     SLV00010
C
C  ***  SET  Y = S * X,  S = P X P SYMMETRIC MATRIX.  ***
C  ***  LOWER TRIANGLE OF  S  STORED ROWWISE.         ***
C
C  ***  PARAMETER DECLARATIONS  ***
C
      INTEGER P
      DOUBLE PRECISION S(1), X(P), Y(P)
C     DIMENSION S(P*(P+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IM1, J, K
      DOUBLE PRECISION XI
C
C  ***  NO INTRINSIC FUNCTIONS  ***
C
C  ***  EXTERNAL FUNCTION  ***
C
      EXTERNAL DOTPRD
      DOUBLE PRECISION DOTPRD
C
C-----------------------------------------------------------------------
C
      J = 1
      DO 10 I = 1, P
         Y(I) = DOTPRD(I, S(J), X)
         J = J + I
 10      CONTINUE
C
      IF (P .LE. 1) GO TO 999
      J = 1
      DO 40 I = 2, P
         XI = X(I)
         IM1 = I - 1
         J = J + 1
         DO 30 K = 1, IM1
              Y(K) = Y(K) + S(J)*XI
              J = J + 1
 30           CONTINUE
 40      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF SLVMUL FOLLOWS  ***
      END
      LOGICAL FUNCTION STOPX(IDUMMY)                                    STO00010
C     *****PARAMETERS...
      INTEGER IDUMMY
C
C     ..................................................................
C
C     *****PURPOSE...
C     THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION)
C     FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT
C     THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A
C     DYNAMIC STOPX.
C
C     *****ALGORITHM NOTES...
C     AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED
C     INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A
C     FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT
C     (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX.
C
C     ..................................................................
C
      STOPX = .FALSE.
      RETURN
      END
      SUBROUTINE VAXPY(P, W, A, X, Y)                                   VAX00010
C
C  ***  SET W = A*X + Y  --  W, X, Y = P-VECTORS, A = SCALAR  ***
C
      INTEGER P
      DOUBLE PRECISION A, W(P), X(P), Y(P)
C
      INTEGER I
C
      DO 10 I = 1, P
 10      W(I) = A*X(I) + Y(I)
      RETURN
      END
      SUBROUTINE VCOPY(P, Y, X)                                         VCO00010
C
C  ***  SET Y = X, WHERE X AND Y ARE P-VECTORS  ***
C
      INTEGER P
      DOUBLE PRECISION X(P), Y(P)
C
      INTEGER I
C
      DO 10 I = 1, P
 10      Y(I) = X(I)
      RETURN
      END
      SUBROUTINE VSCOPY(P, Y, S)                                        VSC00010
C
C  ***  SET P-VECTOR Y TO SCALAR S  ***
C
      INTEGER P
      DOUBLE PRECISION S, Y(P)
C
      INTEGER I
C
      DO 10 I = 1, P
 10      Y(I) = S
      RETURN
      END
      DOUBLE PRECISION FUNCTION V2NORM(P, X)                            V2N00010
C
C  ***  RETURN THE 2-NORM OF THE P-VECTOR X, TAKING  ***
C  ***  CARE TO AVOID THE MOST LIKELY UNDERFLOWS.    ***
C
      INTEGER P
      DOUBLE PRECISION X(P)
C
      INTEGER I, J
      DOUBLE PRECISION ONE, R, SCALE, SQTETA, T, XI, ZERO
C/+
      DOUBLE PRECISION DABS, DSQRT
C/
      EXTERNAL RMDCON
      DOUBLE PRECISION RMDCON
C
C/6
      DATA ONE/1.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C     SAVE SQTETA
C/
      DATA SQTETA/0.D+0/
C
      IF (P .GT. 0) GO TO 10
         V2NORM = ZERO
         GO TO 999
 10   DO 20 I = 1, P
         IF (X(I) .NE. ZERO) GO TO 30
 20      CONTINUE
      V2NORM = ZERO
      GO TO 999
C
 30   SCALE = DABS(X(I))
      IF (I .LT. P) GO TO 40
         V2NORM = SCALE
         GO TO 999
 40   T = ONE
      IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2)
C
C     ***  SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE
C     ***  SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE.
C     ***  THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS.
C
      J = I + 1
      DO 60 I = J, P
         XI = DABS(X(I))
         IF (XI .GT. SCALE) GO TO 50
              R = XI / SCALE
              IF (R .GT. SQTETA) T = T + R*R
              GO TO 60
 50           R = SCALE / XI
              IF (R .LE. SQTETA) R = ZERO
              T = ONE  +  T * R*R
         SCALE = XI
 60      CONTINUE
C
      V2NORM = SCALE * DSQRT(T)
 999  RETURN
C  ***  LAST CARD OF V2NORM FOLLOWS  ***
      END
C///////////////////////////////////////////////////////////////////////
C  ***  RUN NL2SOL ON VARIOUS TEST PROBLEMS, PRINT SUMMARY STATISTICS.  NLM00010
C
C     *****COMMON STORAGE WITH NLTEST.
C
      COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV
      COMMON /TESTCH/ NAME, IRC
      INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2
      REAL RS(5,50)
C/6
      REAL NAME(2,50)
      INTEGER IRC(50)
C/7
C     CHARACTER NAME(2,50)*4, IRC(50)*1
C/
      DOUBLE PRECISION V(1736)
C
C
C     ..................................................................
C
C     *****PURPOSE.
C        THIS MAIN PROGRAM CALLS NLTEST TO RUN NL2SOL, THE NONLINEAR
C     LEAST-SQUARES SOLVER OF REF. 1, ON VARIOUS TEST PROBLEMS.
C
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     THIS MAIN DRIVER IS INTENDED TO CHECK WHETHER THE NL2SOL
C     (NONLINEAR LEAST-SQUARES) PACKAGE WAS SUCCESSFULLY
C     TRANSPORTED TO A NEW MACHINE.
C
C     *****ALGORITHM NOTES.
C     THE TEST PROBLEMS USED ARE FROM REFERENCES (2), (3), AND (4).
C     SOME ADDITIONAL TEST PROBLEMS WERE SUGGESTED BY JORGE MORE (PRI-
C     VATE COMMUNICATION).  CALLS PASSING THESE PROBLEMS TO NLTEST HAVE
C     BEEN COMMENTED OUT (SINCE THERE ARE ENOUGH OTHER PROBLEMS), BUT
C     NOT REMOVED, SINCE THEY MAY BE OF INTEREST TO OTHER RESEARCHERS.
C
C     *****FUNCTIONS AND SUBROUTINES CALLED.
C
C        DFAULT - ESTABLISHES THE DEFAULT PARAMETER SETTINGS FOR
C                 IV AND V.
C
C        IMDCON - IMDCON(2) RETURNS I/O UNIT NUMBER ON WHICH NLTEST
C                  WRITES A SUMMARY OF EACH TEST RUN.
C
C        IVVSET - SUPPLIES NONDEFAULT VALUES FOR IV AND V.
C
C        NLTEST - CALLS NL2SOL, THE NONLINEAR LEAST-SQUARES
C                  PROBLEM SOLVER.
C
C        TODAY  - SUPPLIES DATE AND TIME (OR CURRENT VERSION OF NL2SOL).
C
C     *****REFERENCES.
C
C     (1). DENNIS, J.E.. GAY, D.M.. AND WELSCH, R.E. (1980),
C          AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
C          SUBMITTED TO ACM TRANS. MATH. SOFTWARE.
C          UNDER REVISION.
C
C     (2). GILL, P.E.. AND MURRAY, W. (1976),ALGORITHMS FOR THE
C          SOLUTION OF THE NON-LINEAR LEAST-SQUARES PROBLEM,
C          NPL REPORT NAC71,(NATIONAL PHYSICAL LABORATORY,
C          DIVISION OF NUMERICAL ANALYSIS AND COMPUTING,
C          TEDDINGTON,MIDDLESEX,ENGLAND).
C
C     (3) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS
C        OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING,
C        EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER,
C        ACADEMIC PRESS, NEW YORK.
C
C     (4) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON-
C        LIKE METHOD BASED UPON GAUSSIAN ELIMINATION,
C        SIAM J. NUMER. ANAL. 6, PP. 560-569.
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C     *****INTRINSIC FUNCTIONS.
C/+
      INTEGER MOD
      DOUBLE PRECISION DMAX1
C/
C     *****EXTERNAL FUNCTIONS AND SUBROUTINES.
      EXTERNAL DFAULT, IMDCON, IVVSET, NLTEST, TODAY
      INTEGER IMDCON
C
C     *****LOCAL VARIABLES.
      LOGICAL RSTART
      INTEGER I, J, K, MXFCSV, MXITSV, PU
C/6
      INTEGER JTYP(2)
      REAL DATIME(4)
C/7
C     CHARACTER DATIME(4)*4, JTYP(2)*1
C/
C
C/6
      DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/1H ,1H*/
C/7
C     DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/' ','*'/
C/
C
C-----------------------------------------------------------------------
C
C  ***  ESTABLISH DEFAULT PARAMETER SETTINGS  ***
      CALL DFAULT (IV, V)
      NOUT = IMDCON(2)
C
C  ***  NON-DEFAULT PARAMETER SETTINGS  ***
C
      CALL IVVSET(IV, V)
      PU = IV(21)
C
      JAC = 1
      NPROB = 0
      XSCAL1 = 1
      XSCAL2 = 3
C
C/6
      CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART)
      CALL NLTEST(3,3,2,4HHELI,4HX   ,RSTART)
      CALL NLTEST(4,4,3,4HSING,4HULAR,RSTART)
      CALL NLTEST(7,4,4,4HWOOD,4HS   ,RSTART)
      XSCAL2 = 1
      CALL NLTEST(3,3,5,4HZANG,4HWILL,RSTART)
      XSCAL2 = 3
      CALL NLTEST(5,3,6,4HENGV,4HALL ,RSTART)
      CALL NLTEST(2,2,7,4HBRAN,4HIN  ,RSTART)
      XSCAL2 = 2
      CALL NLTEST(3,2,8,4HBEAL,4HE   ,RSTART)
      CALL NLTEST(5,4,9,4HCRAG,4HG   ,RSTART)
      XSCAL2 = 2
      CALL NLTEST(10,3,10,4HBOX ,4H    ,RSTART)
      MXFCSV = IV(17)
      MXITSV = IV(18)
      IV(17) = 20
      IV(18) = 15
      XSCAL2 = 1
      CALL NLTEST(15,15,11,4HDAVI,4HDON1,RSTART)
      IV(17) = MXFCSV
      IV(18) = MXITSV
      XSCAL2 = 3
      CALL NLTEST(2,2,12,4HFRDS,4HTEIN,RSTART)
      XSCAL2 = 1
      CALL NLTEST(31,6,13,4HWATS,4HON6 ,RSTART)
      CALL NLTEST(31,9,14,4HWATS,4HON9 ,RSTART)
      CALL NLTEST(31,12,15,4HWATS,4HON12,RSTART)
      MXFCSV = IV(17)
      IV(17) = 20
      MXITSV = IV(18)
      IV(18) = 15
      CALL NLTEST(31,20,16,4HWATS,4HON20,RSTART)
      IV(17) = MXFCSV
      IV(18) = MXITSV
      XSCAL2 = 2
      CALL NLTEST(8,8,17,4HCHEB,4HQD8 ,RSTART)
      XSCAL2 = 3
      CALL NLTEST(20,4,18,4HBROW,4HN   ,RSTART)
      CALL NLTEST(15,3,19,4HBARD,4H    ,RSTART)
      XSCAL2 = 1
      CALL NLTEST(10,2,20,4HJENN,4HRICH,RSTART)
      XSCAL2 = 3
      CALL NLTEST(11,4,21,4HKOWA,4HLIK ,RSTART)
      XSCAL2 = 1
      CALL NLTEST(33,5,22,4HOSBO,4HRNE1,RSTART)
      XSCAL2 = 2
      CALL NLTEST(65,11,23,4HOSBO,4HRNE2,RSTART)
      XSCAL2 = 3
      CALL NLTEST(3,2,24,4HMADS,4HEN  ,RSTART)
      XSCAL2 = 1
      IV(17) = 400
      IV(18) = 300
      CALL NLTEST(16,3,25,4HMEYE,4HR   ,RSTART)
C/7
C     CALL NLTEST(2,2,1,'ROSN','BROK',RSTART)
C     CALL NLTEST(3,3,2,'HELI','X   ',RSTART)
C     CALL NLTEST(4,4,3,'SING','ULAR',RSTART)
C     CALL NLTEST(7,4,4,'WOOD','S   ',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(3,3,5,'ZANG','WILL',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(5,3,6,'ENGV','ALL ',RSTART)
C     CALL NLTEST(2,2,7,'BRAN','IN  ',RSTART)
C     XSCAL2 = 2
C     CALL NLTEST(3,2,8,'BEAL','E   ',RSTART)
C     CALL NLTEST(5,4,9,'CRAG','G   ',RSTART)
C     XSCAL2 = 2
C     CALL NLTEST(10,3,10,'BOX ','    ',RSTART)
C     MXFCSV = IV(17)
C     MXITSV = IV(18)
C     IV(17) = 20
C     IV(18) = 15
C     XSCAL2 = 1
C     CALL NLTEST(15,15,11,'DAVI','DON1',RSTART)
C     IV(17) = MXFCSV
C     IV(18) = MXITSV
C     XSCAL2 = 3
C     CALL NLTEST(2,2,12,'FRDS','TEIN',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(31,6,13,'WATS','ON6 ',RSTART)
C     CALL NLTEST(31,9,14,'WATS','ON9 ',RSTART)
C     CALL NLTEST(31,12,15,'WATS','ON12',RSTART)
C     MXFCSV = IV(17)
C     IV(17) = 20
C     MXITSV = IV(18)
C     IV(18) = 15
C     CALL NLTEST(31,20,16,'WATS','ON20',RSTART)
C     IV(17) = MXFCSV
C     IV(18) = MXITSV
C     XSCAL2 = 2
C     CALL NLTEST(8,8,17,'CHEB','QD8 ',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(20,4,18,'BROW','N   ',RSTART)
C     CALL NLTEST(15,3,19,'BARD','    ',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(10,2,20,'JENN','RICH',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(11,4,21,'KOWA','LIK ',RSTART)
C     XSCAL2 = 1
C     CALL NLTEST(33,5,22,'OSBO','RNE1',RSTART)
C     XSCAL2 = 2
C     CALL NLTEST(65,11,23,'OSBO','RNE2',RSTART)
C     XSCAL2 = 3
C     CALL NLTEST(3,2,24,'MADS','EN  ',RSTART)
C     XSCAL2 = 1
C     IV(17) = 400
C     IV(18) = 300
C     CALL NLTEST(16,3,25,'MEYE','R   ',RSTART)
C/
C  ***  BROWN5  ***
C     CALL NLTEST(5,5,26,4HBROW,4HN5  ,RSTART)
C  ***  BROWN10  ***
C     CALL NLTEST(10,10,27,4HBROW,4HN10 ,RSTART)
C  ***  BROWN30  ***
C     CALL NLTEST(30,30,28,4HBROW,4HN30 ,RSTART)
C  ***  BROWN40  ***
C     CALL NLTEST(40,40,29,4HBROW,4HN40 ,RSTART)
C  ***  BARD+10 ***
C     CALL NLTEST(15,3,30,4HBARD,4H+10 ,RSTART)
C  ***  KOWALIK AND OSBORNE + 10  ***
C     CALL NLTEST(11,4,31,4HKOWA,4HL+10,RSTART)
C  ***  MEYER + 10  ***
C     CALL NLTEST(16,3,32,4HMEYE,4HR+10,RSTART)
C  ***  WATSON6 + 10  ***
C     CALL NLTEST(31,6,33,4HWAT6,4H+10 ,RSTART)
C  ***  WATSON9 + 10  ***
C     CALL NLTEST(31,9,34,4HWAT9,4H+10 ,RSTART)
C  ***  WATSON12 + 10  ***
C     CALL NLTEST(31,12,35,4HWAT1,4H2+10,RSTART)
C  ***  WATSON20 + 10  ***
C     CALL NLTEST(31,20,36,4HWAT2,4H0+10,RSTART)
C
C  ***  REPEAT TWO TESTS USING FINITE-DIFFERENCE JACOBIAN  ***
C
      JAC = 2
      XSCAL2 = 1
C
      IV(17) = 50
      IV(18) = 40
C/6
      CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART)
C/7
C     CALL NLTEST(2,2,1,'ROSN','BROK',RSTART)
C/
      V(29) = DMAX1(1.0D-7, V(29))
      IV(17) = 30
      IV(18) = 20
C  ***  BROWN  ***
C/6
      CALL NLTEST(20,4,18,4HBROW,4HN   ,RSTART)
C/7
C     CALL NLTEST(20,4,18,'BROW','N   ',RSTART)
C/
C
      IF (NPROB .EQ. 0 .OR. PU .EQ. 0) STOP
      CALL TODAY(DATIME)
      DO 130 K = 1, NPROB
         IF (MOD(K,56) .EQ. 1) WRITE(PU, 110) DATIME, NPROB
 110     FORMAT(1H1,11X,2A4,2X,2A4,10X,10HSUMMARY OF,I4,
     1          22H NL2SOL TEST RUNS.....,10X,
     2          32H(* = FINITE-DIFFERENCE JACOBIAN)/
     3          48H0 PROBLEM    N   P  NITER   NF   NG  IV1  X0SCAL,5X,
     4          39HFINAL F     PRELDF     NRELDF     RELDX/)
         J = IS(6,K)
         WRITE(PU,120) JTYP(J), NAME(1,K), NAME(2,K),
     1                 (IS(I,K), I=1,5), IRC(K), (RS(I,K), I=1,5)
 120     FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3)
 130     CONTINUE
C
      STOP
C...... LAST CARD OF NLMAIN ............................................
      END
      SUBROUTINE IVVSET(IV, V)                                          IVV00010
C
C  ***  SUPPLY NONDEFAULT IV AND V VALUES FOR NLMAIN  (NL2SOL VER. 2.2).
C
      INTEGER IV(24)
      DOUBLE PRECISION V(100)
C
C     ACTIVATE THE NEXT LINE TO TURN OFF DETAILED SUMMARY PRINTING
C     IV(21) = 0
      RETURN
      END
      SUBROUTINE NLTEST (N, P, NEX, TITLE1, TITLE2, RSTART)             NLT00010
C
C  ***  CALL NL2SOL, SAVE AND PRINT STATISTICS  ***
C
C
      INTEGER N, P, NEX
      LOGICAL RSTART
C/6
      REAL TITLE1, TITLE2
C/7
C     CHARACTER*4 TITLE1, TITLE2
C/
C
      COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV
      COMMON /TESTCH/ NAME, IRC
      INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2
      REAL RS(5,50)
C/6
      INTEGER IRC(50)
      REAL NAME(2,50)
C/7
C     CHARACTER NAME(2,50)*4, IRC(50)*1
C/
      DOUBLE PRECISION V(1736)
C
      LOGICAL RSTRT
      INTEGER I, IRUN, PU, UIP(1)
C/6
      INTEGER ALG(2), JTYP(2), RC(10)
      REAL DATIME(4)
C/7
C     CHARACTER*4 DATIME(4)
C     CHARACTER*2 ALG(2)
C     CHARACTER*1 JTYP(2), RC(10)
C/
      DOUBLE PRECISION ONE, T, URPARM(1), X(20), X0SCAL, ZERO
C
C     ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
      EXTERNAL NL2SNO, NL2SOL, TESTR, TESTJ, TODAY, XINIT
C
C  ***  IV AND V SUBSCRIPTS  ***
C
      INTEGER F, F0, NFCALL, NFCOV, NGCALL, NITER, NREDUC, PREDUC,
     1        PRUNIT, RELDX
C
C/6
      DATA F/10/, F0/13/, NFCALL/6/, NFCOV/40/, NGCALL/30/,
     1     NGCOV/41/, NITER/31/, NREDUC/6/, PREDUC/7/,
     2     PRUNIT/21/, RELDX/17/
C/7
C     PARAMETER (F=10, F0=13, NFCALL=6, NFCOV=40, NGCALL=30,
C    1     NGCOV=41, NITER=31, NREDUC=6, PREDUC=7,
C    2     PRUNIT=21, RELDX=17)
C/
C/6
      DATA ONE/1.D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C/
C/6
      DATA ALG(1),ALG(2)/2HOL,2HNO/, JTYP(1),JTYP(2)/1H ,1H*/
      DATA RC(1)/1H./, RC(2)/1H+/, RC(3)/1HX/, RC(4)/1HR/, RC(5)/1HB/,
     1     RC(6)/1HA/, RC(7)/1HS/, RC(8)/1HF/, RC(9)/1HE/, RC(10)/1HI/
C/7
C     DATA ALG(1),ALG(2)/'OL','NO'/, JTYP(1),JTYP(2)/' ','*'/
C     DATA RC(1)/'.'/, RC(2)/'+'/, RC(3)/'X'/, RC(4)/'R'/, RC(5)/'B'/,
C    1     RC(6)/'A'/, RC(7)/'S'/, RC(8)/'F'/, RC(9)/'E'/, RC(10)/'I'/
C/
C
C-----------------------------------------------------------------------
C
      UIP(1) = NEX
      RSTRT = RSTART
      IF (RSTRT) GO TO 20
         PU = IV(PRUNIT)
         CALL TODAY(DATIME)
         IF (PU .NE. 0) WRITE(PU,10) ALG(JAC), TITLE1, TITLE2, DATIME
 10      FORMAT (1H1//11H ***** NL2S,A2,12H ON PROBLEM ,2A4,6H *****,6X,
     1           2A4,2X,2A4)
C
 20   DO 100 IRUN = XSCAL1, XSCAL2
         IF (RSTRT) GO TO 40
         IV(1) = 12
         X0SCAL = 1.0D1 ** (IRUN-1)
C
C        ***  INITIALIZE THE SOLUTION VECTOR X  ***
         CALL XINIT(P, X, NEX)
         DO 30 I = 1, P
 30           X(I) = X0SCAL * X(I)
C
 40      IF (JAC .EQ. 1)
     1             CALL NL2SOL(N,P,X,TESTR,TESTJ,IV,V,UIP,URPARM,TESTR)
         IF (JAC .EQ. 2)
     1             CALL NL2SNO(N,P,X,TESTR,IV,V,UIP,URPARM,TESTR)
         IF (.NOT. RSTRT .AND. NPROB .LT. 50) NPROB = NPROB + 1
         NAME(1,NPROB) = TITLE1
         NAME(2,NPROB) = TITLE2
         IS(1,NPROB) = N
         IS(2,NPROB) = P
         IS(3,NPROB) = IV(NITER)
         IS(4,NPROB) = IV(NFCALL) - IV(NFCOV)
         IS(5,NPROB) = IV(NGCALL) - IV(NGCOV)
         I = IV(1)
         IRC(NPROB) = RC(I)
         IS(6,NPROB) = JAC
         RS(1,NPROB) = X0SCAL
         RS(2,NPROB) = V(F)
         T = ONE
         IF (V(F0) .GT. ZERO) T = V(PREDUC) / V(F0)
         RS(3,NPROB) = T
         T = ONE
         IF (V(F0) .GT. ZERO) T = V(NREDUC) / V(F0)
         RS(4,NPROB) = T
         RS(5,NPROB) = V(RELDX)
         RSTRT = .FALSE.
         IF (NOUT .EQ. 0) GO TO 100
         IF (NPROB .EQ. 1) WRITE(NOUT,50) DATIME
 50      FORMAT(1H1,11X,2A4,2X,2A4,10X,24HNL2SOL TEST SUMMARY.....,10X,
     1          32H(* = FINITE-DIFFERENCE JACOBIAN)/
     2          48H0 PROBLEM    N   P  NITER   NF   NG  IV1  X0SCAL,5X,
     3          39HFINAL F     PRELDF     NRELDF     RELDX/)
         WRITE(NOUT,60) JTYP(JAC), TITLE1, TITLE2,
     1                (IS(I,NPROB),I=1,5),IRC(NPROB),(RS(I,NPROB),I=1,5)
 60      FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3)
 100     CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF NLTEST FOLLOWS  ***
      END
      SUBROUTINE TESTJ(N, P, X, NFCALL, J, UIPARM, URPARM, UFPARM)      TSJ00010
C
C  ***  PARAMETERS  ***
C
      INTEGER N, P, NFCALL, UIPARM(1)
      DOUBLE PRECISION X(P), J(N,P), URPARM(1)
      EXTERNAL UFPARM
C
C     ..................................................................
C     ..................................................................
C
C     *****PURPOSE.
C     THIS ROUTINE EVALUATES THE JACOBIAN MATRIX  J  FOR THE VARIOUS
C     TEST PROBLEMS LISTED IN REFERENCES (1), (2), AND (3).
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NN IS THE ROW DIMENSION OF  J  AS DECLARED IN THE CALLING
C             PROGRAM.
C        N IS THE ACTUAL NUMBER OF ROWS IN  J  AND IS THE LENGTH OF  R.
C        P IS THE NUMBER OF PARAMETERS BEING ESTIMATED AND HENCE IS
C             THE LENGTH OF X.
C        X IS THE VECTOR OF PARAMETERS AT WHICH THE JACOBIAN MATRIX  J
C             IS TO BE COMPUTED.
C        NFCALL IS THE INVOCATION COUNT OF  TESTR  AT THE TIME WHEN  R
C             WAS EVALUATED AT  X.  TESTR IGNORES NFCALL.
C        R IS THE RESIDUAL VECTOR AT  X  (AND IS IGNORED).
C        NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING
C             SOLVED.
C        URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED).
C        UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED).
C        TESTR IS THE SUBROUTINE THAT COMPUTES  R  (AND IS IGNORED).
C
C     ON OUTPUT.
C
C        J IS THE JACOBIAN MATRIX AT X.
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS
C     SUCH AS NL2SOL.  IN PARTICULAR, THESE PROBLEMS MAY BE USED TO
C     CHECK WHETHER  NL2SOL  HAS BEEN SUCCESSFULLY TRANSPORTED TO
C     A PARTICULAR MACHINE.
C
C     *****ALGORITHM NOTES.
C     NONE
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C     NONE
C
C     *****REFERENCES
C     (1) GILL, P.E.; & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION
C        OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71.
C
C     (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS
C        OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING,
C        EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER,
C        ACADEMIC PRESS, NEW YORK.
C
C     (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON-
C        LIKE METHOD BASED UPON GAUSSIAN ELIMINATION,
C        SIAM J. NUMER. ANAL. 6, PP. 560-569.
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C  ***  LOCAL VARIABLES AND CONSTANTS  ***
C
      DOUBLE PRECISION E, EXPMIN, R2, T, THETA, TI, TIM1, TIP1, TPI,
     1   TPIM1, TPIP1, TWOPI, U, UFTOLG, UKOW(11), V, W, Z, ZERO
      INTEGER I, K, NEX, NM1
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      REAL FLOAT
      DOUBLE PRECISION DBLE, DCOS, DEXP, DLOG, DMIN1, DSIN, DSQRT
C/
      EXTERNAL RMDCON
      DOUBLE PRECISION DFLOAT, RMDCON
C
C/6
C/6                                                                    T
      DATA TWOPI/6.283185307179586D+0/, ZERO/0.D+0/
C/7
C     PARAMETER (TWOPI=6.283185307179586D+0, ZERO=0.D+0)
C/
C/6
C/7
C     SAVE EXPMIN, UFTOLG
C/
      DATA UKOW(1)/4.0D0/, UKOW(2)/2.0D0/, UKOW(3)/1.0D0/,
     1   UKOW(4)/5.0D-1/, UKOW(5)/2.5D-1/, UKOW(6)/1.67D-1/,
     2   UKOW(7)/1.25D-1/, UKOW(8)/1.0D-1/, UKOW(9)/8.33D-2/,
     3   UKOW(10)/7.14D-2/, UKOW(11)/6.25D-2/
C  ***  MACHINE DEPENDENT CONSTANT  ***
      DATA EXPMIN/0.0D0/, UFTOLG/0.D0/
C
      DFLOAT(II) = DBLE(FLOAT(II))
C
C-----------------------------------------------------------------------
C
      NEX = UIPARM(1)
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100,
     1   1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100,
     2   2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100,
     3   2500, 1300, 1400, 1500, 1600), NEX
C
C  ***  ROSENBROCK  ***
 100  J(1,1) = -2.0D1*X(1)
      J(1,2) = 1.0D1
      J(2,1) = -1.0D0
      J(2,2) = 0.0D0
      GO TO 9999
C  ***  HELIX  ***
 200  T = X(1)**2 + X(2)**2
      TI = 1.D2/(TWOPI*T)
      J(1,1) = TI*X(2)
      T = 1.D1/DSQRT(T)
      J(2,1) = X(1)*T
      J(3,1) = 0.D0
      J(1,2) = -TI*X(1)
      J(2,2) = X(2)*T
      J(3,2) = 0.D0
      J(1,3) = 1.D1
      J(2,3) = 0.D0
      J(3,3) = 1.D0
      GO TO 9999
C  ***  SINGULAR  ***
 300  DO 301 K = 1,4
         DO 301 I = 1,4
 301          J(I,K) = 0.D0
      J(1,1) = 1.D0
      J(1,2) = 1.D1
      J(2,3) = DSQRT(5.D0)
      J(2,4) = -J(2,3)
      J(3,2) = 2.D0*(X(2) - 2.D0*X(3))
      J(3,3) = -2.D0*J(3,2)
      J(4,1) = DSQRT(4.D1)*(X(1) - X(4))
      J(4,4) = -J(4,1)
      GO TO 9999
C  ***  WOODS  ***
 400  DO 401 K = 1,4
         DO 401 I = 1,7
 401            J(I,K) = 0.D0
      J(1,1) = -2.D1*X(1)
      J(1,2) = 1.D1
      J(2,1) = -1.D0
      J(3,4) = DSQRT(9.D1)
      J(3,3) = -2.D0*X(3)*J(3,4)
      J(4,3) = -1.D0
      J(5,2) = DSQRT(9.9D0)
      J(5,4) = J(5,2)
      J(6,2) = DSQRT(0.2D0)
      J(7,4) = J(6,2)
      GO TO 9999
C  ***  ZANGWILL  ***
 500  DO 501 K = 1,3
         DO 501 I = 1,3
 501            J(I,K) = 1.D0
      J(1,2) = -1.D0
      J(2,1) = -1.D0
      J(3,3) = -1.D0
      GO TO 9999
C  ***  ENGVALL  ***
 600  J(1,1) = 2.D0*X(1)
      J(1,2) = 2.D0*X(2)
      J(1,3) = 2.D0*X(3)
      J(2,1) = J(1,1)
      J(2,2) = J(1,2)
      J(2,3) = 2.D0*(X(3) - 2.D0)
      J(3,1) = 1.D0
      J(3,2) = 1.D0
      J(3,3) = 1.D0
      J(4,1) = 1.D0
      J(4,2) = 1.D0
      J(4,3) = -1.D0
      T = 2.D0*(5.D0*X(3) - X(1) + 1.D0)
      J(5,1) = 3.D0*X(1)**2 - T
      J(5,2) = 6.D0*X(2)
      J(5,3) = 5.D0*T
      GO TO 9999
C  ***  BRANIN  ***
 700  J(1,1) = 4.D0
      J(1,2) = 4.D0
      J(2,1) = 3.D0 + (X(1) - 2.D0)*(3.D0*X(1) - 2.D0*X(2) - 2.D0) +
     1   X(2)*X(2)
      J(2,2) = 1.D0 + 2.D0*(2.D0*X(1) - X(2)*X(2)) - (X(1) - X(2))**2
      GO TO 9999
C  ***  BEALE  ***
 800  J(1,1) = X(2) - 1.D0
      J(1,2) = X(1)
      J(2,1) = X(2)**2 - 1.D0
      J(2,2) = 2.D0*X(1)*X(2)
      J(3,1) = X(2)**3 - 1.D0
      J(3,2) = 3.D0*X(1)*(X(2)**2)
      GO TO 9999
C  ***  CRAGG & LEVY  ***
 900  DO 901 I = 1,5
         DO 901 K = 1,4
 901          J(I,K) = 0.D0
      T = DEXP(X(1))
      J(1,2) = -2.D0*(T - X(2))
      J(1,1) = -T * J(1,2)
      J(2,2) = 3.0D1*(X(2) - X(3))**2
      J(2,3) = -J(2,2)
      J(3,3) = 2.D0*DSIN(X(3) - X(4))/(DCOS(X(3) - X(4)))**3
      J(3,4) = -J(3,3)
      J(4,1) = 4.D0*X(1)**3
      J(5,4) = 1.D0
      GO TO 9999
C  ***  BOX  ***
 1000 IF (EXPMIN .EQ. ZERO) EXPMIN = 1.999D0*DLOG(RMDCON(2))
      DO 1001 I = 1,10
         TI = -0.1D0*DFLOAT(I)
         E = ZERO
         T = X(1)*TI
         IF (T .GE. EXPMIN) E = DEXP(T)
         J(I,1) = TI*E
         E = ZERO
         T = X(2)*TI
         IF (T .GE. EXPMIN) E = DEXP(T)
         J(I,2) = -TI*E
         J(I,3) = DEXP(1.D1*TI) - DEXP(TI)
 1001    CONTINUE
      GO TO 9999
C  ***  DAVIDON 1  ***
 1100 NM1 = N-1
      DO 1101 I = 1,NM1
         TI = DFLOAT(I)
         T = 1.D0
         DO 1101 K = 1,P
              J(I,K) = T
              T = T*TI
 1101         CONTINUE
      J(N,1) = 1.D0
      DO 1102 K = 2,P
 1102    J(N,K) = 0.D0
      GO TO 9999
C  ***  FREUDENSTEIN & ROTH  ***
 1200 J(1,1) = 1.D0
      J(1,2) = -2.D0 + X(2)*(1.D1 - 3.D0*X(2))
      J(2,1) = 1.D0
      J(2,2) = -1.4D1 + X(2)*(2.D0 + 3.D0*X(2))
      GO TO 9999
C  ***  WATSON  ***
 1300 CONTINUE
 1400 CONTINUE
 1500 CONTINUE
 1600 DO 1603 I = 1,29
         TI = DFLOAT(I)/2.9D1
         R2 = X(1)
         T= 1.D0
         DO 1601 K = 2,P
              T = T*TI
              R2 = R2 + T*X(K)
 1601    CONTINUE
         R2 = -2.D0*R2
         J(I,1) = R2
         T = 1.D0
         R2 = TI*R2
         DO 1602 K = 2,P
              J(I,K) = T*(DFLOAT(K-1) + R2)
              T = T*TI
 1602    CONTINUE
 1603 CONTINUE
      DO 1604 I = 30,31
         DO 1604 K = 2,P
 1604         J(I,K) = 0.D0
      J(30,1) = 1.D0
      J(31,1) = -2.D0*X(1)
      J(31,2) = 1.D0
      GO TO 9999
C  ***  CHEBYQUAD  ***
 1700 DO 1701 K = 1,N
         TIM1 = -1.D0/DFLOAT(N)
         Z = 2.D0*X(K) - 1.D0
         TI = Z*TIM1
         TPIM1 = 0.D0
         TPI = 2.D0*TIM1
         Z = Z + Z
         DO 1701 I = 1,N
              J(I,K) = TPI
              TPIP1 = 4.D0*TI + Z*TPI - TPIM1
              TPIM1 = TPI
              TPI = TPIP1
              TIP1 = Z*TI - TIM1
              TIM1 = TI
              TI = TIP1
 1701         CONTINUE
      GO TO 9999
C  ***  BROWN AND DENNIS  ***
 1800 DO 1801 I = 1, N
         TI = 0.2D0*DFLOAT(I)
         J(I,1) = 2.0D0*(X(1) + X(2)*TI - DEXP(TI))
         J(I,2) = TI*J(I,1)
         T = DSIN(TI)
         J(I,3) = 2.0D0*(X(3) + X(4)*T - DCOS(TI))
         J(I,4) = T*J(I,3)
 1801    CONTINUE
      GO TO 9999
C  ***  BARD  ***
 1900 DO 1901 I = 1,15
         J(I,1) = -1.D0
         U = DFLOAT(I)
         V = 1.6D1 - U
         W = DMIN1 (U,V)
         T = U/(X(2)*V + X(3)*W)**2
         J(I,2) = V*T
         J(I,3) = W*T
 1901 CONTINUE
      GO TO 9999
C  *** JENNRICH & SAMPSON  ***
 2000 DO 2001 I = 1,10
         TI = DFLOAT(I)
         J(I,1) = -TI*DEXP(TI*X(1))
         J(I,2) = -TI*DEXP(TI*X(2))
 2001    CONTINUE
      GO TO 9999
C  ***  KOWALIK & OSBORNE  ***
 2100 DO 2101 I = 1,11
         T = -1.D0/(UKOW(I)**2 + X(3)*UKOW(I) + X(4))
         J(I,1) = T*(UKOW(I)**2 + X(2)*UKOW(I))
         J(I,2) = X(1)*UKOW(I)*T
         T = T*J(I,1)*X(1)
         J(I,3) = UKOW(I)*T
         J(I,4) = T
 2101 CONTINUE
      GO TO 9999
C  ***  OSBORNE 1  ***
 2200 DO 2201 I = 1,33
         TI = 1.0D1*DFLOAT(1-I)
         J(I,1) = -1.D0
         J(I,2) = -DEXP(X(4)*TI)
         J(I,3) = -DEXP(X(5)*TI)
         J(I,4) = TI*X(2)*J(I,2)
         J(I,5) = TI*X(3)*J(I,3)
 2201    CONTINUE
      GO TO 9999
C  ***  OSBORNE 2  ***
C     ***  UFTOLG IS A MACHINE-DEPENDENT CONSTANT.  IT IS JUST SLIGHTLY
C     ***  LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER.
 2300 IF (UFTOLG .EQ. 0.D0) UFTOLG = 1.999D0 * DLOG(RMDCON(2))
      DO 2302 I = 1,65
         TI = DFLOAT(1 - I)*1.D-1
         J(I,1) = -DEXP(X(5)*TI)
         J(I,5) = X(1)*TI*J(I,1)
         DO 2301 K = 2,4
              T = X(K + 7) + TI
              R2 = 0.D0
              THETA = -X(K+4)*T*T
              IF (THETA .GT. UFTOLG) R2 = -DEXP(THETA)
              J(I,K) = R2
              R2 = -T*R2*X(K)
              J(I,K+4) = R2*T
              J(I,K+7) = 2.D0*X(K+4)*R2
 2301         CONTINUE
 2302    CONTINUE
      GO TO 9999
C  ***  MADSEN  ***
 2400 J(1,1) = 2.D0*X(1) + X(2)
      J(1,2) = 2.D0*X(2) + X(1)
      J(2,1) = DCOS(X(1))
      J(2,2) = 0.D0
      J(3,1) = 0.D0
      J(3,2) = -DSIN(X(2))
      GO TO 9999
C  ***  MEYER  ***
 2500 DO 2501 I = 1, 16
         TI = DFLOAT(5*I + 45)
         U = TI + X(3)
         T = DEXP(X(2)/U)
         J(I,1) = T
         J(I,2) = X(1)*T/U
         J(I,3) = -X(1)*X(2)*T/(U*U)
 2501    CONTINUE
      GO TO 9999
C  ***  BROWN  ***
 2600 CONTINUE
 2700 CONTINUE
 2800 CONTINUE
 2900 NM1 = N - 1
      DO 2901 K = 1, N
         DO 2901 I = 1, NM1
              J(I,K) = 1.0D0
              IF (I .EQ. K) J(I,K) = 2.0D0
 2901         CONTINUE
      DO 2903 K = 1, N
         T = 1.0D0
         DO 2902 I = 1,N
              IF (I .NE. K) T = T*X(I)
 2902         CONTINUE
         J(N,K) = T
 2903    CONTINUE
      GO TO 9999
C
C
 9999 RETURN
      END
      SUBROUTINE TESTR(N, P, X, NFCALL, R, UIPARM, URPARM, UFPARM)      TES00010
C
C     *****PARAMETERS.
C
      INTEGER N, P, NFCALL, UIPARM(1)
      DOUBLE PRECISION X(P), R(N), URPARM(1)
      EXTERNAL UFPARM
C
C     ..................................................................
C     ..................................................................
C
C     *****PURPOSE.
C     THIS ROUTINE EVALUATES  R  FOR THE VARIOUS TEST FUNCTIONS IN
C        REFERENCES (1), (2), AND (3), AS WELL AS FOR SOME VARIATIONS
C        SUGGESTED BY JORGE MORE (PRIVATE COMMUNICATION) ON SOME OF
C        THESE TEST PROBLEMS (FOR NEX .GE. 30).
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        N IS THE LENGTH OF R.
C        P IS THE LENGTH OF X.
C        X IS THE POINT AT WHICH THE RESIDUAL VECTOR R IS TO BE
C             COMPUTED.
C        NFCALL IS THE INVOCATION COUNT OF TESTR.
C        NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING
C             SOLVED.
C        URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED).
C        UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED).
C
C     ON OUTPUT.
C
C        R IS THE RESIDUAL VECTOR AT X.
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS
C     SUCH AS NL2SOL.  IN PARTICULAR, THESE PROBLEMS MAY BE USED TO
C     CHECK WHETHER  NL2SOL  HAS BEEN SUCCESSFULLY TRANSPORTED TO
C     A PARTICULAR MACHINE.
C
C     *****ALGORITHM NOTES.
C     NONE
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C     NONE
C
C     *****REFERENCES
C     (1) GILL, P.E.. & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION
C        OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71.
C
C     (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS
C        OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING,
C        EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER,
C        ACADEMIC PRESS, NEW YORK.
C
C     (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON-
C        LIKE METHOD BASED UPON GAUSSIAN ELIMINATION,
C        SIAM J. NUMER. ANAL. 6, PP. 560-569.
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     ..................................................................
C     ..................................................................
C
C  ***  LOCAL VARIABLES AND CONSTANTS  ***
C
      DOUBLE PRECISION E1, E2, FLOATN, RI, R1, R2, T, THETA, TI, TIM1,
     1             TIP1, TWOPI, T1, T2, U, V, W, Z
      DOUBLE PRECISION YBARD(15), YKOW(11), UKOW(11), YOSB1(33),
     1             YOSB2(65), YMEYER(16)
      INTEGER I, J, NEX, NM1
      DOUBLE PRECISION EXPMAX, EXPMIN, UFTOLG
C  ***  INTRINSIC FUNCTIONS  ***
C/+
      INTEGER MOD
      REAL FLOAT
      DOUBLE PRECISION DATAN2, DBLE, DCOS, DEXP, DLOG, DMIN1, DSIN,
     1                 DSQRT
C/
      EXTERNAL RMDCON
      DOUBLE PRECISION DFLOAT, RMDCON
C/6
      DATA TWOPI/6.283185307179586D+0/
C/7
C     PARAMETER (TWOPI=6.283185307179586D+0)
C/
C/6
C/7
C     SAVE EXPMAX, EXPMIN, UFTOLG
C/
      DATA YBARD(1)/1.4D-1/, YBARD(2)/1.8D-1/, YBARD(3)/2.2D-1/,
     1   YBARD(4)/2.5D-1/, YBARD(5)/2.9D-1/, YBARD(6)/3.2D-1/,
     2   YBARD(7)/3.5D-1/, YBARD(8)/3.9D-1/, YBARD(9)/3.7D-1/,
     3   YBARD(10)/5.8D-1/, YBARD(11)/7.3D-1/, YBARD(12)/9.6D-1/,
     4   YBARD(13)/1.34D0/, YBARD(14)/2.10D0/, YBARD(15)/4.39D0/
      DATA YKOW(1)/1.957D-1/, YKOW(2)/1.947D-1/, YKOW(3)/1.735D-1/,
     1   YKOW(4)/1.600D-1/, YKOW(5)/8.44D-2/, YKOW(6)/6.27D-2/,
     2   YKOW(7)/4.56D-2/, YKOW(8)/3.42D-2/, YKOW(9)/3.23D-2/,
     3   YKOW(10)/2.35D-2/, YKOW(11)/2.46D-2/
      DATA UKOW(1)/4.0D0/, UKOW(2)/2.0D0/, UKOW(3)/1.0D0/,
     1   UKOW(4)/5.0D-1/, UKOW(5)/2.5D-1/, UKOW(6)/1.67D-1/,
     2   UKOW(7)/1.25D-1/, UKOW(8)/1.0D-1/, UKOW(9)/8.33D-2/,
     3   UKOW(10)/7.14D-2/, UKOW(11)/6.25D-2/
      DATA YOSB1(1)/8.44D-1/, YOSB1(2)/9.08D-1/, YOSB1(3)/9.32D-1/,
     1   YOSB1(4)/9.36D-1/, YOSB1(5)/9.25D-1/, YOSB1(6)/9.08D-1/,
     2   YOSB1(7)/8.81D-1/, YOSB1(8)/8.50D-1/, YOSB1(9)/8.18D-1/,
     3   YOSB1(10)/7.84D-1/, YOSB1(11)/7.51D-1/, YOSB1(12)/7.18D-1/,
     4   YOSB1(13)/6.85D-1/, YOSB1(14)/6.58D-1/, YOSB1(15)/6.28D-1/,
     5   YOSB1(16)/6.03D-1/, YOSB1(17)/5.80D-1/, YOSB1(18)/5.58D-1/,
     6   YOSB1(19)/5.38D-1/, YOSB1(20)/5.22D-1/, YOSB1(21)/5.06D-1/,
     7   YOSB1(22)/4.90D-1/, YOSB1(23)/4.78D-1/, YOSB1(24)/4.67D-1/,
     8   YOSB1(25)/4.57D-1/, YOSB1(26)/4.48D-1/, YOSB1(27)/4.38D-1/,
     9   YOSB1(28)/4.31D-1/, YOSB1(29)/4.24D-1/, YOSB1(30)/4.20D-1/,
     A   YOSB1(31)/4.14D-1/, YOSB1(32)/4.11D-1/, YOSB1(33)/4.06D-1/
      DATA YOSB2(1)/1.366D0/, YOSB2(2)/1.191D0/, YOSB2(3)/1.112D0/,
     1   YOSB2(4)/1.013D0/, YOSB2(5)/9.91D-1/, YOSB2(6)/8.85D-1/,
     2   YOSB2(7)/8.31D-1/, YOSB2(8)/8.47D-1/, YOSB2(9)/7.86D-1/,
     3   YOSB2(10)/7.25D-1/, YOSB2(11)/7.46D-1/, YOSB2(12)/6.79D-1/,
     4   YOSB2(13)/6.08D-1/, YOSB2(14)/6.55D-1/, YOSB2(15)/6.16D-1/,
     5   YOSB2(16)/6.06D-1/, YOSB2(17)/6.02D-1/, YOSB2(18)/6.26D-1/,
     6   YOSB2(19)/6.51D-1/, YOSB2(20)/7.24D-1/, YOSB2(21)/6.49D-1/,
     7   YOSB2(22)/6.49D-1/, YOSB2(23)/6.94D-1/, YOSB2(24)/6.44D-1/,
     8   YOSB2(25)/6.24D-1/, YOSB2(26)/6.61D-1/, YOSB2(27)/6.12D-1/,
     9   YOSB2(28)/5.58D-1/, YOSB2(29)/5.33D-1/, YOSB2(30)/4.95D-1/,
     A   YOSB2(31)/5.00D-1/, YOSB2(32)/4.23D-1/, YOSB2(33)/3.95D-1/,
     B   YOSB2(34)/3.75D-1/, YOSB2(35)/3.72D-1/, YOSB2(36)/3.91D-1/,
     C   YOSB2(37)/3.96D-1/, YOSB2(38)/4.05D-1/, YOSB2(39)/4.28D-1/,
     D   YOSB2(40)/4.29D-1/, YOSB2(41)/5.23D-1/, YOSB2(42)/5.62D-1/,
     E   YOSB2(43)/6.07D-1/, YOSB2(44)/6.53D-1/, YOSB2(45)/6.72D-1/,
     F   YOSB2(46)/7.08D-1/, YOSB2(47)/6.33D-1/, YOSB2(48)/6.68D-1/,
     G   YOSB2(49)/6.45D-1/, YOSB2(50)/6.32D-1/, YOSB2(51)/5.91D-1/,
     H   YOSB2(52)/5.59D-1/, YOSB2(53)/5.97D-1/, YOSB2(54)/6.25D-1/,
     I   YOSB2(55)/7.39D-1/, YOSB2(56)/7.10D-1/, YOSB2(57)/7.29D-1/,
     J   YOSB2(58)/7.20D-1/, YOSB2(59)/6.36D-1/, YOSB2(60)/5.81D-1/
      DATA YOSB2(61)/4.28D-1/, YOSB2(62)/2.92D-1/, YOSB2(63)/1.62D-1/,
     1   YOSB2(64)/9.8D-2/, YOSB2(65)/5.4D-2/
      DATA YMEYER(1)/3.478D4/, YMEYER(2)/2.861D4/, YMEYER(3)/2.365D4/,
     1   YMEYER(4)/1.963D4/, YMEYER(5)/1.637D4/, YMEYER(6)/1.372D4/,
     2   YMEYER(7)/1.154D4/, YMEYER(8)/9.744D3/, YMEYER(9)/8.261D3/,
     3   YMEYER(10)/7.030D3/, YMEYER(11)/6.005D3/, YMEYER(12)/5.147D3/,
     4   YMEYER(13)/4.427D3/, YMEYER(14)/3.820D3/, YMEYER(15)/3.307D3/,
     5   YMEYER(16)/2.872D3/
C
      DATA EXPMAX/0.D0/, UFTOLG/0.D0/
C
      DFLOAT(II) = DBLE(FLOAT(II))
C
C-----------------------------------------------------------------------
C
      NEX = UIPARM(1)
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100,
     1   1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100,
     2   2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100,
     3   2500, 1300, 1400, 1500, 1600), NEX
C
C  ***  ROSENBROCK   ***
 100  R(1) = 1.0D1*(X(2) - X(1)**2)
      R(2) = 1.0D0 - X(1)
      GO TO 9999
C  ***  HELIX   ***
 200  THETA = DATAN2(X(2), X(1))/TWOPI
      IF (X(1) .LE. 0.D0 .AND. X(2) .LE. 0.D0) THETA = THETA + 1.D0
      R(1) = 1.0D1*(X(3) - 1.0D1*THETA)
      R(2) = 1.0D1*(DSQRT(X(1)**2 + X(2)**2) - 1.0D0)
      R(3) = X(3)
      GO TO 9999
C  ***  SINGULAR   ***
 300  R(1) = X(1) + 1.0D1*X(2)
      R(2) = DSQRT(5.0D0)*(X(3) - X(4))
      R(3) = (X(2) - 2.0D0*X(3))**2
      R(4) = DSQRT(1.0D1)*(X(1) - X(4))**2
      GO TO 9999
C  ***  WOODS   ***
 400  R(1) = 1.0D1*(X(2) - X(1)**2)
      R(2) = 1.0D0 - X(1)
      R(3) = DSQRT(9.0D1)*(X(4) - X(3)**2)
      R(4) = 1.0D0 - X(3)
      R(5) = DSQRT(9.9D0)*(X(2) + X(4) - 2.D0)
      T = DSQRT(2.0D-1)
      R(6) = T*(X(2) - 1.0D0)
      R(7) = T*(X(4) - 1.0D0)
      GO TO 9999
C  ***  ZANGWILL
 500  R(1) = X(1) - X(2) + X(3)
      R(2) = -X(1) + X(2) + X(3)
      R(3) = X(1) + X(2) - X(3)
      GO TO 9999
C  ***  ENGVALL   ***
 600  R(1) = X(1)**2 + X(2)**2 + X(3)**2 - 1.0D0
      R(2) = X(1)**2 + X(2)**2 + (X(3) - 2.0D0)**2 - 1.0D0
      R(3) = X(1) + X(2) + X(3) - 1.0D0
      R(4) = X(1) + X(2) - X(3) + 1.0D0
      R(5) = X(1)**3 + 3.0D0*X(2)**2 + (5.0D0*X(3) - X(1) + 1.0D0)**2
     1               - 3.6D1
      GO TO 9999
C  ***  BRANIN ***
 700  R(1) = 4.0D0*(X(1) + X(2))
      R(2) = R(1) + (X(1) - X(2))*((X(1) - 2.0D0)**2 +
     1       X(2)**2 - 1.0D0)
      GO TO 9999
C  ***  BEALE  ***
 800  R(1) = 1.5D0 - X(1)*(1.0D0 - X(2))
      R(2) = 2.25D0 - X(1)*(1.0D0 - X(2)**2)
      R(3) = 2.625D0 - X(1)*(1.0D0 -  X(2)**3)
      GO TO 9999
C  ***  CRAGG AND LEVY  ***
 900  R(1) = (DEXP(X(1)) - X(2))**2
      R(2) = 1.0D1*(X(2) - X(3))**3
      R(3) = ( DSIN(X(3) - X(4)) / DCOS(X(3) - X(4)) )**2
      R(4) = X(1)**4
      R(5) = X(4) - 1.0D0
      GO TO 9999
C  ***  BOX  ***
 1000 IF (EXPMAX .GT. 0.D0) GO TO 1001
         EXPMAX = 1.999D0 * DLOG(RMDCON(5))
         EXPMIN = 1.999D0 * DLOG(RMDCON(2))
 1001 IF (-EXPMAX .GE. DMIN1(X(1), X(2), X(3))) GO TO 1003
      DO 1002 I = 1,10
         TI = -0.1D0*DFLOAT(I)
         T1 = TI*X(1)
         E1 = 0.D0
         IF (T1 .GT. EXPMIN) E1 = DEXP(T1)
         T2 = TI*X(2)
         E2 = 0.D0
         IF (T2 .GT. EXPMIN) E2 = DEXP(T2)
         R(I) = (E1 - E2) - X(3)*(DEXP(TI) - DEXP(1.0D1*TI))
 1002 CONTINUE
      GO TO 9999
 1003 NFCALL = -1
      GO TO 9999
C  ***  DAVIDON 1  ***
 1100 NM1 = N - 1
      DO 1102 I = 1, NM1
         R1 = 0.0D0
         TI = DFLOAT(I)
         T = 1.D0
         DO 1101 J = 1,P
              R1 = R1 + T*X(J)
              T = T*TI
 1101         CONTINUE
         R(I) = R1
 1102    CONTINUE
      R(N) = X(1) - 1.0D0
      GO TO 9999
C  ***  FREUDENSTEIN AND ROTH  ***
 1200 R(1) = -1.3D1 + X(1) - 2.0D0*X(2) + 5.0D0*X(2)**2 - X(2)**3
      R(2) = -2.9D1 + X(1) - 1.4D1*X(2) + X(2)**2 + X(2)**3
      GO TO 9999
C  ***  WATSON  ***
 1300  CONTINUE
 1400  CONTINUE
 1500  CONTINUE
 1600 DO 1602 I = 1, 29
         TI = DFLOAT(I)/2.9D1
         R1 = 0.0D0
         R2 = X(1)
         T = 1.0D0
         DO 1601 J = 2, P
              R1 = R1 + DFLOAT(J-1)*T*X(J)
              T = T*TI
              R2 = R2 + T*X(J)
 1601         CONTINUE
         R(I) = R1 - R2*R2 - 1.0D0
         IF (NEX .GE. 33 .AND. NEX .LE. 36) R(I) = R(I) + 10.D0
 1602    CONTINUE
      R(30) = X(1)
      R(31) = X(2) - X(1)**2 - 1.0D0
      IF (NEX .LT. 33 .OR. NEX .GT. 36) GO TO 9999
      R(30) = R(30) + 10.D0
      R(31) = R(31) + 10.D0
      GO TO 9999
C  ***  CHEBYQUAD  ***
 1700 DO 1701 I = 1,N
 1701    R(I) = 0.0D0
      DO 1702 J = 1,N
         TIM1 = 1.0D0
         TI = 2.0D0*X(J) - 1.0D0
         Z = TI + TI
         DO 1702 I = 1,N
              R(I) = R(I) + TI
              TIP1 = Z*TI -TIM1
              TIM1 = TI
              TI = TIP1
 1702         CONTINUE
      FLOATN = DFLOAT(N)
      DO 1703 I = 1,N
         TI = 0.0D0
         IF (MOD(I,2) .EQ. 0) TI = -1.0D0/DFLOAT(I*I - 1)
         R(I) = TI - R(I)/FLOATN
 1703    CONTINUE
      GO TO 9999
C  ***  BROWN AND DENNIS  ***
 1800  DO 1801 I = 1, N
         TI = 0.2D0*DFLOAT(I)
         R(I) = (X(1) + X(2)*TI - DEXP(TI))**2 +
     1             (X(3) + X(4)*DSIN(TI) - DCOS(TI))**2
 1801    CONTINUE
      GO TO 9999
C  ***  BARD  ***
 1900 DO 1901 I = 1, 15
         U = DFLOAT(I)
         V = 1.6D1 - U
         W = DMIN1(U,V)
         R(I) = YBARD(I) - (X(1) + U/(X(2)*V + X(3)*W))
         IF (NEX .EQ. 30) R(I) = R(I) + 10.D0
 1901    CONTINUE
      GO TO 9999
C  ***  JENNRICH AND SAMPSON  ***
 2000 DO 2001 I = 1, 10
         TI = DFLOAT(I)
         R(I) = 2.0D0 + 2.0D0*TI - (DEXP(TI*X(1)) +
     1          DEXP(TI*X(2)))
 2001    CONTINUE
      GO TO 9999
C  ***  KOWALIK AND OSBORNE  ***
 2100 DO 2101 I = 1, 11
         R(I) = YKOW(I) - X(1)*(UKOW(I)**2 + X(2)*UKOW(I))/(UKOW(I)**2 +
     1          X(3)*UKOW(I) + X(4))
         IF (NEX .EQ. 31) R(I) = R(I) + 10.D0
 2101    CONTINUE
      GO TO 9999
C  ***  OSBORNE 1  ***
 2200 DO 2201 I = 1, 33
         TI = 1.0D1*DFLOAT(1-I)
         R(I) = YOSB1(I) - (X(1) + X(2)*DEXP(X(4)*TI) +
     1          X(3)*DEXP(X(5)*TI))
 2201    CONTINUE
      GO TO 9999
C  ***  OSBORNE 2  ***
C     ***  UFTOLG IS A MACHINE-DEPENDENT CONSTANT.  IT IS JUST SLIGHTLY
C     ***  LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER.
 2300 IF (UFTOLG .EQ. 0.D0) UFTOLG = 1.999D0 * DLOG(RMDCON(2))
      DO 2302 I = 1, 65
         TI = 0.1D0*DFLOAT(1-I)
         RI = X(1)*DEXP(X(5)*TI)
         DO 2301 J = 2, 4
              T = 0.D0
              THETA = -X(J+4) * (TI + X(J+7))**2
              IF (THETA .GT. UFTOLG) T = DEXP(THETA)
              RI = RI + X(J)*T
 2301         CONTINUE
         R(I) = YOSB2(I) - RI
 2302 CONTINUE
      GO TO 9999
C  ***  MADSEN  ***
 2400 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2)
      R(2) = DSIN(X(1))
      R(3) = DCOS(X(2))
      GO TO 9999
C  ***  MEYER  ***
 2500 DO 2501 I = 1, 16
         TI = DFLOAT(5*I + 45)
         R(I)=X(1)*DEXP(X(2)/(TI + X(3))) - YMEYER(I)
         IF (NEX .EQ. 32) R(I) = R(I) + 10.D0
 2501    CONTINUE
      GO TO 9999
C  ***  BROWN  ***
 2600 CONTINUE
 2700 CONTINUE
 2800 CONTINUE
 2900 T = X(1) - DFLOAT(N + 1)
      DO 2901 I = 2, N
 2901    T = T + X(I)
      NM1 = N - 1
      DO 2902 I = 1, NM1
 2902    R(I) = T + X(I)
      T = X(1)
      DO 2903 I = 2, N
 2903    T = T * X(I)
      R(N) = T - 1.0D0
      GO TO 9999
C
 9999 RETURN
C     ..... LAST CARD OF TESTR .........................................
      END
      SUBROUTINE TODAY(DATIME)                                          TOD00010
C
C  ***  SUPPLY SUMSOL VERSION  ***
C
C/6
      REAL DATIME(4), DT1, DT2, DT3, DT4
      DATA DT1,DT2,DT3,DT4/4HNL2S,4HOL  ,4HVER.,4H2.2 /
C/7
C     CHARACTER*4 DATIME(4), DT1, DT2, DT3, DT4
C     DATA DT1,DT2,DT3,DT4/'NL2S','OL  ','VER.','2.2 '/
C/
C
      DATIME(1) = DT1
      DATIME(2) = DT2
      DATIME(3) = DT3
      DATIME(4) = DT4
 999  RETURN
C  ***  LAST LINE OF DATIME FOLLOWS  ***
      END
      SUBROUTINE XINIT(P, X, NEX)                                       XIN00010
C
C     *****PARAMETERS...
C
      INTEGER NEX, P
      DOUBLE PRECISION X(P)
C
C     ..................................................................
C
C     *****PURPOSE...
C     THIS ROUTINE INITIALIZES THE SOLUTION VECTOR X ACCORDING TO
C     THE INITIAL VALUES FOR THE VARIOUS TEST FUNCTIONS GIVEN IN
C     REFERENCES (1), (2), AND (3).
C     SUBROUTINES TESTR AND TESTJ.  (SEE TESTR FOR REFERENCES.)
C
C     *****PARAMETER DESCRIPTION...
C     ON INPUT...
C
C        NEX IS THE TEST PROBLEM NUMBER.
C
C        P IS THE NUMBER OF PARAMETERS.
C
C     ON OUTPUT...
C
C        X IS THE INITIAL GUESS TO THE SOLUTION.
C
C     *****APPLICATION AND USAGE RESTRICTIONS...
C     THIS ROUTINE IS CALLED BY NLTEST.
C
C     ..................................................................
C
C     *****LOCAL VARIABLES...
      INTEGER I
      DOUBLE PRECISION PP1INV
C     *****INTRINSIC FUNCTIONS...
C/+
      REAL FLOAT
      DOUBLE PRECISION DBLE
C/
      DFLOAT(II) = DBLE(FLOAT(II))
C
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100,
     1   1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100,
     2   2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100,
     3   2500, 1300, 1400, 1500, 1600),NEX
C
C  ***  ROSENBROCK  ***
 100  X(1) = -1.2D0
      X(2) = 1.0D0
      GO TO 9999
C  ***  HELIX  ***
 200  X(1) = -1.0D0
      X(2) = 0.0D0
      X(3) = 0.0D0
      GO TO 9999
C  *** SINGULAR  ***
 300  X(1) = 3.0D0
      X(2) = -1.0D0
      X(3) = 0.0D0
      X(4) = 1.0D0
      GO TO 9999
C  ***  WOODS  ***
 400  X(1) = -3.0D0
      X(2) = -1.0D0
      X(3) = -3.0D0
      X(4) = -1.0D0
      GO TO 9999
C  ***  ZANGWILL  ***
 500  X(1) = 1.0D2
      X(2) = -1.0D0
      X(3) = 2.5D0
      GO TO 9999
C  ***  ENGVALL  ***
 600  X(1) = 1.0D0
      X(2) = 2.0D0
      X(3) = 0.0D0
      GO TO 9999
C  *** BRANIN  ***
 700  X(1) = 2.0D0
      X(2) = 0.0D0
      GO TO 9999
C  ***  BEALE  ***
 800  X(1) = 1.0D-1
      X(2) = 1.0D-1
      GO TO 9999
C  *** CRAGG AND LEVY  ***
 900  X(1) = 1.0D0
      X(2) = 2.0D0
      X(3) = 2.0D0
      X(4) = 2.0D0
      GO TO 9999
C  ***  BOX  ***
 1000 X(1) = 0.0D0
      X(2) = 1.0D1
      X(3) = 2.0D1
      GO TO 9999
C  ***  DAVIDON 1  ***
 1100 DO 1101 I = 1,P
 1101    X(I) = 0.0D0
      GO TO 9999
C  ***  FREUDENSTEIN AND ROTH  ***
 1200 X(1) = 1.5D1
      X(2) = -2.0D0
      GO TO 9999
C  ***  WATSON  ***
 1300 CONTINUE
 1400 CONTINUE
 1500 CONTINUE
 1600 DO 1601 I = 1,P
 1601    X(I) = 0.0D0
      GO TO 9999
C  ***  CHEBYQUAD  ***
 1700 PP1INV = 1.0D0/DFLOAT(P + 1)
      DO 1701 I = 1, P
 1701    X(I) = DFLOAT(I)*PP1INV
      GO TO 9999
C  *** BROWN AND DENNIS  ***
 1800 X(1) = 2.5D1
      X(2) = 5.0D0
      X(3) = -5.0D0
      X(4) = -1.0D0
      GO TO 9999
C  ***  BARD  ***
 1900 X(1) = 1.D0
      X(2) = 1.D0
      X(3) = 1.D0
      GO TO 9999
C  ***  JENNRICH AND SAMPSON  ***
 2000 X(1) = 3.0D-1
      X(2) = 4.0D-1
      GO TO 9999
C  ***  KOWALIK AND OSBORNE  ***
 2100 X(1) = 2.5D-1
      X(2) = 3.9D-1
      X(3) = 4.15D-1
      X(4) = 3.9D-1
      GO TO 9999
C  ***  OSBORNE 1  ***
 2200 X(1) = 5.0D-1
      X(2) = 1.5D0
      X(3) = -1.0D0
      X(4) = 1.0D-2
      X(5) = 2.0D-2
      GO TO 9999
C  ***  OSBORNE 2  ***
 2300 X(1) = 1.3D0
      X(2) = 6.5D-1
      X(3) = 6.5D-1
      X(4) = 7.0D-1
      X(5) = 6.0D-1
      X(6) = 3.0D0
      X(7) = 5.0D0
      X(8) = 7.0D0
      X(9) = 2.0D0
      X(10) = 4.5D0
      X(11) = 5.5D0
      GO TO 9999
C  ***  MADSEN  ***
 2400 X(1) = 3.0D0
      X(2) = 1.0D0
      GO TO 9999
C  ***  MEYER  **
 2500 X(1) = 2.0D-2
      X(2) = 4.0D3
      X(3) = 2.5D2
      GO TO 9999
C  ***  BROWN  ***
 2600 CONTINUE
 2700 CONTINUE
 2800 CONTINUE
 2900 DO 2901 I = 1, P
 2901    X(I) = 5.D-1
      GO TO 9999
C
C
 9999 RETURN
      END

 
