C
C
C********** COPYRIGHT 1996 EDWIN H. KAUFMAN JR., DAVID J. LEEMING,
C********** GERALD D. TAYLOR
C********** THE AUTHORS GRATEFULLY ACKNOWLEDGE THE ASSISTANCE OF
C********** CENTRAL MICHIGAN UNIVERSITY, THE UNIVERSITY OF VICTORIA
C********** (CANADA), AND COLORADO STATE UNIVERSITY.
C********** PERMISSION TO USE, COPY, MODIFY, AND DISTRIBUTE THIS
C********** SOFTWARE FOR ANY PURPOSE WITHOUT FEE IS HEREBY GRANTED,
C********** PROVIDED THAT THIS ENTIRE NOTICE IS INCLUDED IN ANY
C********** SOFTWARE WHICH IS OR INCLUDES A COPY OR MODIFICATION OF
C********** THIS SOFTWARE AND IN ALL COPIES OF THE SUPPORTING
C********** DOCUMENTATION FOR SUCH SOFTWARE.
C********** THIS SOFTWARE IS PROVIDED "AS IS", WITHOUT EXPRESS OR
C********** IMPLIED WARRANTY.  IN PARTICULAR, NEITHER THE AUTHORS NOR
C********** THEIR UNIVERSITIES MAKE ANY REPRESENTATION OR WARRANTY OF
C********** ANY KIND CONCERNING THE MERCHANTIBILITY OF THIS SOFTWARE
C********** OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
C
C
C WELCOME TO CONMAX, VERSION 1.7
C
C THIS PACKAGE WAS LAST REVISED ON DECEMBER 4, 1996.
C
C SUCCESS STORIES AND BUG REPORTS MAY BE SENT TO EDWIN H. KAUFMAN, JR.
C BY E-MAIL AT  32ZEJ7N@CMUVM.CSV.CMICH.EDU
C ALTHOUGH WE DO NOT PROMISE TO ATTEMPT TO FIX BUGS, WE MAY LOOK AT
C THEM AS TIME PERMITS.
C
C THIS PACKAGE CONSISTS OF THREE PARTS:
C
C (I) THE USERS GUIDE YOU ARE READING,
C
C (II) A SAMPLE DRIVER PROGRAM AND SUBROUTINE FNSET, AND
C
C (III) THE CONMAX SUBPROGRAMS.
C
C THIS PACKAGE IS SELF-CONTAINED.  ONCE THE USER HAS SET (ONCE) THE
C THREE MACHINE DEPENDENT CONSTANTS AND THE PRECISION AS DESCRIBED IN (A)
C BELOW, THE PACKAGE CAN BE COMPILED AND EXECUTED TO RUN THE EXAMPLE IN
C THE SAMPLE DRIVER PROGRAM AND SUBROUTINE FNSET.  DETAILED INSTRUCTIONS
C FOR APPLYING THE PROGRAM TO OTHER PROBLEMS ARE GIVEN IN THIS USERS GUIDE.
C
C CONMAX CONSISTS OF TWO PROGRAMS FOR SOLVING THE PROBLEM
C
C     MINIMIZE W
C
C     SUBJECT TO
C
C     ABS(FUN(I) - CONFUN(I,1)) .LE. W      IF ICNTYP(I)=2,
C
C     CONFUN(I,1)               .LE. W      IF ICNTYP(I)=1,
C
C     CONFUN(I,1)               .LE. 0.0    IF ICNTYP(I)=-1 OR -2,
C
C WHERE IF ICNTYP(I)=-1 THE CONSTRAINT IS LINEAR (I.E. THE LEFT SIDE
C CONSISTS OF A LINEAR COMBINATION OF THE PARAMETERS IN THE VECTOR ARRAY
C PARAM PLUS A CONSTANT) AND IF ICNTYP(I)=-2 THE CONSTRAINT MAY BE
C NONLINEAR.
C
C THUS WE ARE CHOOSING THE PARAMETERS TO MINIMIZE THE LEFT SIDES OF
C THE TYPE 2 AND TYPE 1 (I.E. PRIMARY) CONSTRAINTS SUBJECT TO THE
C TYPE -1 AND TYPE -2 (I.E. STANDARD) CONSTRAINTS.
C
C IF THERE ARE NO PRIMARY CONSTRAINTS THE PROGRAM WILL ATTEMPT TO
C FIND A FEASIBLE POINT (THAT IS, A VECTOR PARAM FOR WHICH THE TYPE -1
C AND TYPE -2 CONSTRAINTS ARE SATISFIED WITHIN A TOLERANCE TOLCON
C DESCRIBED BELOW) WHICH IS RELATIVELY CLOSE TO THE USER SUPPLIED INITIAL
C APPROXIMATION, THEN RETURN.
C
C TO USE THE PACKAGE THE USER MUST DO THREE THINGS:
C
C (A)  SET THE THREE MACHINE DEPENDENT CONSTANTS AND THE PRECISION.
C
C IF DOUBLE PRECISION IS DESIRED AND THE NETLIB-SUPPLIED SUBPROGRAMS
C I1MACH, D1MACH, AND R1MACH ARE BEING USED, THEN THIS HAS BEEN TAKEN
C CARE OF ALREADY.
C
C IF DOUBLE PRECISION IS DESIRED BUT THE NETLIB-SUPPLIED SUBPROGRAMS
C I1MACH, D1MACH, AND R1MACH ARE NOT BEING USED, THEN REPLACE THE CS
C IN COLUMN 1 OF THE SUBPROGRAMS I1MACH AND D1MACH INCLUDED IN THIS
C PACKAGE BY BLANKS (EXCEPT REPLACE CC BY C) AND ADJUST THE ASSIGNMENT
C STATEMENTS IN THESE SUBPROGRAMS TO SET
C
C I1MACH(1) = (THE INPUT UNIT NUMBER FOR THE MACHINE BEING USED),
C
C I1MACH(2) = (THE OUTPUT UNIT NUMBER FOR THE MACHINE BEING USED),
C
C D1MACH(3) = B**(-ITT), WHERE B IS THE BASE FOR FLOATING POINT NUMBERS
C   AND ITT IS THE NUMBER OF BASE B DIGITS IN THE MANTISSA.
C
C IF ONE WISHES TO CHANGE THE PRECISION TO SINGLE PRECISION (FOR
C EXAMPLE), THEN ONLY THREE THINGS NEED TO BE DONE:
C
C   (1) REPLACE ALL THE STATEMENTS  ONE=1.0D0  IN THE PACKAGE BY  ONE=1.0,
C
C   (2) PLACE A  C  IN COLUMN 1 OF ALL THE STATEMENTS IN THE PACKAGE
C       IMPLICIT REAL*8 (A-H,O-Z),
C
C   (3) REPLACE ALL OCCURENCES OF  D1MACH  IN THE PACKAGE BY  R1MACH
C       IF THE NETLIB SUPPLIED SUBPROGRAMS I1MACH, D1MACH, AND R1MACH ARE
C       BEING USED, AND OTHERWISE MERELY CHANGE THE DEFINITION OF
C       D1MACH(3)  IN SUBPROGRAM D1MACH TO REFLECT SINGLE PRESISION.
C
C (WE NOTE HERE THAT THE ONLY ACTIVE WRITE STATEMENTS IN THIS PACKAGE
C ARE IN THE SAMPLE DRIVER PROGRAM, BUT SOME OF THOSE WHICH HAVE BEEN
C COMMENTED OUT (ALONG WITH THE STATEMENTS  NWRIT=I1MACH(2)) ELSEWHERE
C IN THE PROGRAM COULD PROVE USEFUL, ESPECIALLY THE STATEMENT
C WRITE(NWRIT,1100)... IN SUBROUTINE CONMAX.)
C
C (B)  CREATE A DRIVER (I.E. MAIN) PROGRAM WHICH DIMENSIONS THE ARRAYS
C FUN, PTTBL, IWORK, WORK, PARAM, AND ERROR, SETS THE INPUT VARIABLES
C IOPTN, NPARM, NUMGR, ITLIM, IFUN, IPTB, INDM, LIWRK, LWRK, PARAM
C (AND POSSIBLY ALSO FUN AND PTTBL), CONTAINS THE STATEMENT
C
C     CALL CONMAX(IOPTN,NPARM,NUMGR,ITLIM,FUN,IFUN,PTTBL,IPTB,
C    *INDM,IWORK,LIWRK,WORK,LWRK,ITER,PARAM,ERROR)
C
C AND PRINTS THE OUTPUT.  IN ADDITION, WITH CERTAIN SETTINGS OF IOPTN
C (SEE BELOW) THE USER WILL ALSO SUPPLY INPUT VALUES IN IWORK(1) AND
C WORK(1), AND/OR IWORK(2), AND/OR WORK(2);  SINCE IWORK AND WORK ARE
C CHANGED BY THE PROGRAM, IN THIS CASE THE USER WILL NEED TO RESET THESE
C VALUES EACH TIME CONMAX IS CALLED.
C
C (C)  CREATE A SUBROUTINE FNSET (DESCRIBED LATER) FOR INPUT OF FUNCTION
C DATA AND THE VECTOR ARRAY ICNTYP, WHICH SPECIFIES THE TYPE OF THE
C CONSTRAINTS.
C
C THE VARIABLES IN THE CALLING SEQUENCE FOR CONMAX ARE THE FOLLOWING.
C
C IOPTN  (INPUT)  THIS IS THE OPTION SWITCH, WHICH SHOULD BE SET TO
C        0 UNLESS ONE OR MORE OF THE EXTRA OPTIONS DESCRIBED BELOW
C        IS USED.
C
C NPARM  (INPUT)  THIS IS THE NUMBER OF PARAMETERS IN THE PROBLEM.
C        (THEY ARE STORED IN PARAM--SEE BELOW.)
C
C NUMGR  (INPUT)  THIS IS THE TOTAL NUMBER OF CONSTRAINTS.
C
C ITLIM  (INPUT)  THIS IS THE LIMIT ON THE NUMBER OF ITERATIONS, I.E.
C        THE LIMIT ON THE NUMBER OF TIMES THE PROGRAM REDUCES W.  IF
C        ITLIM IS SET TO 0 THE PROGRAM WILL COMPUTE THE ERRORS FOR
C        THE INITIAL APPROXIMATION AND STOP WITHOUT CHECKING
C        FEASIBILITY.
C
C FUN    (OPTIONAL INPUT)  (VECTOR ARRAY OF DIMENSION IFUN)  THIS IS
C        A VECTOR ARRAY IN WHICH DATA OR FUNCTION VALUES IN TYPE 2
C        CONSTRAINTS (SEE ABOVE) CAN BE STORED.  FUN(I) NEED NOT BE
C        ASSIGNED A VALUE IF IT IS NOT GOING TO BE USED.
C
C IFUN   (INPUT)  THIS IS THE DIMENSION OF FUN IN THE DRIVER PROGRAM.
C        IT MUST BE .GE. THE LARGEST INDEX I FOR WHICH FUN(I) IS USED
C        UNLESS NO FUN(I) IS USED, IN WHICH CASE IT MUST BE .GE. 1.
C
C PTTBL  (OPTIONAL INPUT)  (MATRIX ARRAY OF DIMENSION (IPTB,INDM))
C        ROW I OF THIS ARRAY NORMALLY CONTAINS A POINT USED IN THE ITH
C        CONSTRAINT.  THE ENTRIES IN ROW I NEED NOT BE ASSIGNED VALUES IF
C        SUCH A POINT IS NOT USED IN THE ITH CONSTRAINT.
C        (EXAMPLE:  IF THE LEFT SIDE OF CONSTRAINT I IS A POLYNOMIAL IN
C        ONE INDEPENDENT VARIABLE, THEN THE VALUE OF THE INDEPENDENT
C        VARIABLE SHOULD BE IN PTTBL(I,1), AND THE COEFFICIENTS SHOULD BE
C        IN PARAM.)
C        PTTBL CAN ALSO BE USED TO PASS OTHER INFORMATION FROM THE DRIVER
C        PROGRAM TO SUBROUTINE FNSET.
C
C IPTB   (INPUT)  THIS IS THE FIRST DIMENSION OF PTTBL IN THE DRIVER
C        PROGRAM.  IT MUST BE .GE. THE LARGEST SUBSCRIPT I FOR WHICH A
C        VALUE PTTBL(I,J) IS USED, AND MUST BE .GE. 1 IF NO SUCH VALUES
C        ARE USED.
C
C INDB   (INPUT)  THIS IS THE SECOND DIMENSION OF PTTBL IN THE DRIVER
C        PROGRAM.  IT MUST BE .GE. THE LARGEST SUBSCRIPT J FOR WHICH A
C        VALUE PTTBL(I,J) IS USED, AND MUST BE .GE. 1 IF NO SUCH VALUES
C        ARE USED.
C
C IWORK  (INPUT)  (VECTOR ARRAY OF DIMENSION LIWRK)  THIS IS AN INTEGER
C        WORK ARRAY.  THE USER NEED NOT PLACE ANY VALUES IN IT, EXCEPT
C        POSSIBLY CERTAIN OPTIONAL INFORMATION AS DESCRIBED BELOW.
C
C LIWRK  (INPUT)  THIS IS THE DIMENSION OF IWORK IN THE DRIVER PROGRAM.
C        IT MUST BE AT LEAST 7*NUMGR + 7*NPARM + 3.  IF NOT, CONMAX WILL
C        RETURN WITH THIS MINIMUM VALUE MULTIPLIED BY -1 AS A WARNING.
C
C WORK   (INPUT)  (VECTOR ARRAY OF DIMENSION LWRK)  THIS IS A FLOATING
C        POINT WORK ARRAY.  THE USER NEED NOT PLACE ANY VALUES IN IT,
C        EXCEPT POSSIBLY CERTAIN OPTIONAL INFORMATION AS DESCRIBED BELOW.
C
C LWRK   (INPUT)  THIS IS THE DIMENSION OF WORK IN THE DRIVER PROGRAM.
C        IT MUST BE AT LEAST 2*NPARM**2 + 4*NUMGR*NPARM + 11*NUMGR +
C        27*NPARM + 13.  IF NOT, CONMAX WILL RETURN WITH THIS MINIMUM
C        VALUE MULTIPLIED BY -1 AS A WARNING.
C
C ITER   (OUTPUT)  THIS IS THE NUMBER OF ITERATIONS PERFORMED BY CONMAX,
C        INCLUDING THOSE USED IN ATTEMPTING TO GAIN FEASIBILITY,
C        UNTIL EITHER IT CAN NO LONGER IMPROVE THE SITUATION OR THE
C        ITERATION LIMIT  IS REACHED.  IF ITER=ITLIM IT IS POSSIBLE
C        THAT THE PROGRAM  COULD FURTHER REDUCE W IF RESTARTED
C        (POSSIBLY WITH THE NEW PARAMETERS).  ITER=-1 IS A SIGNAL
C        THAT TYPE -1 FEASIBILITY COULD NOT BE ACHIEVED, IN THIS CASE
C        ERROR WILL CONTAIN THE VALUES COMPUTED USING THE USER
C        SUPPLIED INITIAL APPROXIMATION.  ITER=-2 IS A SIGNAL THAT
C        TYPE -1 FEASIBILITY WAS ACHIEVED BUT TYPE -2 FEASIBILITY
C        COULD NOT BE ACHIEVED, IN THIS CASE VALUES IN ERROR
C        CORRESPONDING TO TYPE 1 OR TYPE 2 CONSTRAINTS WILL BE ZERO.
C
C PARAM  (INPUT AND OUTPUT)  (VECTOR ARRAY OF DIMENSION AT LEAST NPARM
C        IN THE DRIVER PROGRAM)  THE USER SHOULD PLACE AN INITIAL GUESS
C        FOR THE PARAMETERS IN PARAM, AND ON OUTPUT PARAM WILL CONTAIN
C        THE BEST PARAMETERS CONMAX HAS BEEN ABLE TO FIND.  IF THE
C        INITIAL PARAM IS NOT FEASIBLE THE PROGRAM WILL FIRST TRY TO
C        FIND A FEASIBLE PARAM.
C
C ERROR  (OUTPUT)  (VECTOR ARRAY OF DIMENSION AT LEAST NUMGR + 3 IN THE
C        DRIVER PROGRAM)  FOR I=1,...,NUMGR, CONMAX WILL PLACE IN
C        ERROR(I) THE ERROR IN CONSTRAINT I (DEFINED TO BE THE VALUE
C        OF THE LEFT SIDE OF CONSTRAINT I, EXCEPT WITHOUT THE ABSOLUTE
C        VALUE IN TYPE 2 CONSTRAINTS).  FURTHER,
C
C   ERROR(NUMGR+1) WILL BE THE (PRINCIPAL) ERROR NORM, THAT IS, THE
C        MAXIMUM VALUE OF THE LEFT SIDES OF THE TYPE 2 (INCLUDING THE
C        ABSOLUTE VALUE) AND TYPE 1 CONSTRAINTS.
C
C   ERROR(NUMGR+2) WILL BE THE MAXIMUM VALUE OF THE LEFT SIDES OF THE
C        TYPE -1 CONSTRAINTS, OR 0.0 IF THERE ARE NO TYPE -1
C        CONSTRAINTS.  EXCEPT FOR ROUNDOFF ERROR AND SMALL TOLERANCES
C        IN SOME SUBROUTINES THIS VALUE WILL NORMALLY BE .LE. 0.0, AND
C        IT WILL NOT BE ALLOWED TO BE .GT. TOLCON IN THE MAIN PART OF
C        THE PROGRAM.
C
C   ERROR(NUMGR+3) WILL BE THE MAXIMUM VALUE OF THE LEFT SIDES OF THE
C        TYPE -2 CONSTRAINTS, OR 0.0 IF THERE ARE NO TYPE -2
C        CONSTRAINTS.  THIS VALUE SHOULD BE .LE. TOLCON, SINCE THE
C        PROGRAM WILL NOT EVEN ATTEMPT TO COMPUTE VALUES FOR THE
C        TYPE 2 AND TYPE 1 CONSTRAINTS OTHERWISE (EXCEPT FOR VALUES
C        CORRESPONDING TO THE INITIAL PARAMETERS PLACED IN PARAM BY
C        THE USER).  THE USER CAN USE THIS FEATURE TO INSERT TYPE -2
C        OR -1 CONSTRAINTS TO KEEP THE PARAMETERS AWAY FROM VALUES
C        WHERE A TYPE 2 OR TYPE 1 CONSTRAINT IS UNDEFINED.
C
C
C THE SUBPROGRAM FNSET CREATED BY THE USER MUST HAVE AS ITS FIRST THREE
C STATEMENTS
C
C     SUBROUTINE FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
C    *INDFN,ICNTYP,CONFUN)
C
C     IMPLICIT REAL*8 (A-H,O-Z)
C
C     DIMENSION PTTBL(IPTB,INDM),PARAM(NPARM),ICNTYP(NUMGR),
C    *CONFUN(NUMGR,NPARM+1)
C
C THE FIRST EIGHT VARIABLES IN THE CALLING SEQUENCE FOR FNSET ARE FOR
C INPUT TO FNSET, WITH THE FIRST FIVE VARIABLES BEING EXACTLY AS THE
C USER SET THEM IN THE DRIVER PROGRAM.  IF THE TEN THOUSANDS DIGIT OF
C IOPTN WAS SET TO 0, FNSET SHOULD BE WRITTEN TO PLACE THE APPROPRIATE
C VALUES IN ICNTYP AND CONFUN USING THE PARAMETERS IN PARAM, AS FOLLOWS.
C
C ICNTYP(IPT) = THE TYPE OF THE IPT(TH) CONSTRAINT (I.E. 2, 1, -1,
C   OR -2), OR THE USER CAN SET ICNTYP(IPT)=0 AS A SIGNAL TO IGNORE
C   CONSTRAINT IPT.
C
C CONFUN(IPT,1) = THE APPROPRIATE VALUE AS DISCUSSED ABOVE.  (THIS CAN
C   BE LEFT UNDEFINED IF ICNTYP(IPT)=0.)
C
C IF INDFN=1 (WHICH IS THE ONLY POSSIBILITY OTHER THAN INDFN=0) THEN IN
C ADDITION TO THE ABOVE, FOR J=1,...,NPARM, FNSET SHOULD COMPUTE
C
C CONFUN(IPT,J+1) = THE VALUE OF THE PARTIAL DERIVATIVE WITH RESPECT
C   TO PARAM(J) OF THE FUNCTION WHOSE VALUE WAS COMPUTED IN
C   CONFUN(IPT,1) (UNLESS ICNTYP(IPT)=0, IN WHICH CASE THESE VALUES
C   NEED NOT BE COMPUTED).
C
C
C THE USER HAS SEVERAL EXTRA OPTIONS WHICH ARE ACTIVATED BY SETTING
C IOPTN TO A VALUE OTHER THAN 0; MORE THAN ONE AT A TIME CAN BE USED.
C IN PARTICULAR,
C
C IF THE ONES DIGIT OF IOPTN IS 0, THEN THE USER SHOULD GIVE FORMULAS
C IN FNSET FOR COMPUTING THE PARTIAL DERIVATIVES WHEN INDFN=1  AS DESCRIBED
C ABOVE.
C
C IF THE USER SETS THE ONES DIGIT OF IOPTN TO 1, THEN INDFN WILL ALWAYS
C BE 0 WHEN FNSET IS CALLED, AND THE PROGRAM WILL AUTOMATICALLY
C APPROXIMATE THE PARTIAL DERIVATIVES WHEN REQUIRED USING THE FOLLOWING
C CENTERED DIFFERENCE FORMULA:
C PARTIAL DERIVATIVE WITH RESPECT TO THE JTH VARIABLE (WHERE 1 .LE. J
C .LE. NPARM) OF THE FUNCTION WHOSE VALUE IS COMPUTED IN CONFUN(IPT,1)
C (WHERE 1 .LE. IPT .LE. NUMGR) IS APPROXIMATELY THE VALUE OF THIS
C FUNCTION WHEN THE JTH COMPONENT OF PARAM IS INCREASED BY DELT, MINUS
C THE VALUE OF THIS FUNCTION WHEN THE JTH COMPONENT OF PARAM IS
C DECREASED BY DELT, ALL DIVIDED BY 2.0*DELT, WHERE DELT = SQRT(B**(-ITT)),
C WHERE B IS THE BASE FOR FOR FLOATING POINT NUMBERS AND ITT IS THE NUMBER
C OF BASE B DIGITS IN THE MANTISSA.
C
C IF THE TENS DIGIT OF IOPTN IS 0, THE PROGRAM WILL NOT GIVE UP
C UNTIL EITHER AN ITERATION FAILS TO PRODUCE A REDUCTION ABS(ENCHG) OF
C MORE THAN 100.0*B**(-ITT) IN THE PRINCIPAL ERROR NORM, OR ITLIM
C ITERATIONS HAVE BEEN USED.
C
C IF THE TENS DIGIT OF IOPTN IS 1, THE PROGRAM WILL ALSO GIVE UP IF
C ABS(ENCHG) .LT. ENCSM FOR LIMSM CONSECUTIVE STEPS IN THE MAIN PART OF
C THE PROGRAM (I.E. AFTER TYPE -1 AND TYPE -2 FEASIBILITY HAVE BOTH BEEN
C ACHIEVED).  THIS OPTION MAY BE USEFUL IN SAVING SOME TIME BY
C FORESTALLING A LONG STRING OF ITERATIONS AT THE END OF A RUN WITH ONLY
C A TINY IMPROVEMENT IN EACH ONE.  ENCSM AND LIMSM ARE TRANSMITTED TO
C CONMAX IN WORK(1) AND IWORK(1) RESPECTIVELY.  WORK(1) AND IWORK(1) DO
C NOT NEED TO BE ASSIGNED VALUES IF THE TENS DIGIT OF IOPTN IS 0.
C
C IF THE HUNDREDS DIGIT OF IOPTN IS 0 OR 2, THEN THE INTERNAL PARAMETER
C NSTEP WILL BE GIVEN THE DEFAULT VALUE 1.  NSTEP IS THE NUMBER OF
C RUNGE-KUTTA STEPS USED IN EACH RK ITERATION.
C
C IF THE HUNDREDS DIGIT OF IOPTN IS 1 OR 3, THEN THE VALUE OF NSTEP USED
C WILL BE THE POSITIVE INTEGER VALUE PLACED IN IWORK(2) BY THE USER IN THE
C DRIVER PROGRAM.  SETTING NSTEP LARGER THAN 1 MAY ALLOW THE PROGRAM TO
C SUCCEED ON DIFFICULT PROBLEMS WHERE THE CONVERGENCE WOULD BE EXTREMELY
C SLOW WITH NSTEP=1, BUT IT WILL GENERALLY CAUSE MORE COMPUTER TIME TO BE
C USED IN EACH RK ITERATION.  IWORK(2) DOES NOT NEED TO BE ASSIGNED A
C VALUE IF THE HUNDREDS DIGIT OF IOPTN IS 0 OR 2.  (NSTEP IS SOMETIMES
C CALLED THE OVERDRIVE PARAMETER.)
C
C IF THE HUNDREDS DIGIT OF IOPTN IS 0 OR 1, THEN THE INTERNAL PARAMETER
C TOLCON WILL BE GIVEN THE DEFAULT VALUE SQRT(B**(-ITT)), WHERE B IS THE
C BASE FOR FLOATING POINT NUMBERS AND ITT IS THE NUMBER OF BASE B DIGITS
C IN THE MANTISSA.
C
C IF THE HUNDREDS DIGIT OF IOPTN IS 2 OR 3, THEN THE VALUE OF TOLCON USED
C WILL BE THE VALUE PLACED IN WORK(2) BY THE USER IN THE DRIVER PROGRAM.
C THIS VALUE SHOULD ALWAYS BE NONNEGATIVE.  IF THERE ARE NO TYPE -2 OR -1
C CONSTRAINTS THEN THE SETTING OF TOLCON WILL HAVE NO EFFECT, BUT IF
C THERE ARE TYPE -2 OR -1 CONSTRAINTS THEN IN GENERAL SMALLER VALUES OF
C TOLCON MAY GIVE MORE ACCURACY IN THE FINAL ANSWER, BUT MAY SLOW DOWN
C OR PREVENT CONVERGENCE, WHILE LARGER VALUES OF TOLCON MAY HAVE THE
C REVERSE EFFECT.  IN PARTICULAR, IF THE TYPE -2 AND -1 CONSTRAINTS
C CANNOT BE SATISFIED SUMULTANEOUSLY WITH STRICT INEQUALITY (THIS CASE
C COULD OCCUR, FOR EXAMPLE, IF AN EQUALITY CONSTRAINT G = 0.0 WAS
C ENTERED AS THE TWO INEQUALITY CONSTRAINTS G .LE. 0.0 AND
C -G .LE. 0.0), THEN SETTING TOLCON=0.0 WILL ALMOST CERTAINLY CAUSE THE
C PROGRAM TO FAIL, SINCE AT EACH ITERATION THE PROGRAM WILL NOT ACCEPT
C PROSPECTIVE NEW VALUES OF THE PARAMETERS UNLESS IT CAN CORRECT THEM
C BACK INTO THE RELAXED FEASIBLE REGION WHERE CONFUN(IPT,1) .LE. TOLCON
C FOR ALL THE TYPE -2 AND -1 CONSTRAINTS.
C
C IF THE THOUSANDS DIGIT OF IOPTN IS 0, THE PROGRAM WILL USE THE RK METHOD
C (WHICH INVOLVES APPLYING FOURTH ORDER RUNGE-KUTTA TO A SYSTEM OF
C DIFFERENTIAL EQUATIONS), THEN IF THIS FAILS IT WILL TRY TO REDUCE
C W WITH AN SLP STEP (I.E. SUCCESSIVE LINEAR PROGRAMMING WITH A TRUST
C REGION), THEN GO BACK TO RK IF THE SLP STEP REDUCES W.
C
C IF THE THOUSANDS DIGIT OF IOPTN IS 1, THE PROGRAM WILL USE SLP STEPS ONLY.
C IN GENERAL, IN SOME PROBLEMS SLP WORKS VERY WELL, AND IN THOSE
C PROBLEMS IT WILL USUALLY BE FASTER THAN RK BECAUSE IT REQUIRES FEWER
C GRADIENT EVALUATIONS THAN RK, BUT IN OTHER PROBLEMS THE CONVERGENCE
C OF SLP MAY BE EXCRUCIATINGLY SLOW, AND THE MORE POWERFUL RK METHOD
C MAY BE MUCH FASTER.
C
C IF THE THOUSANDS DIGIT OF IOPTN IS 2 THE PROGRAM WILL USE THE RK METHOD
C ONLY, QUITTING WHEN RK CAN NO LONGER PRODUCE AN IMPROVEMENT.  THIS
C MAY GIVE A LITTLE LESS ACCURACY THAN SETTING THE THOUSANDS DIGIT TO 0,
C BUT MAY SAVE SIGNIFICANT COMPUTER TIME IN SOME CASES.
C
C IF THE TEN THOUSANDS DIGIT OF IOPTN IS 0, THEN FNSET SHOULD BE WRITTEN AS
C DESCRIBED ABOVE.
C
C IF THE USER SETS THE TEN THOUSANDS DIGIT OF IOPTN TO 1, THEN FNSET SHOULD BE
C WRITTEN AS DESCRIBED ABOVE EXCEPT THAT THE COMPUTATIONS SHOULD BE DONE
C FOR ALL IPT=1,..,NUMGR INSTEAD OF FOR A SINGLE GIVEN VALUE OF IPT.
C THIS OPTION MAY SAVE COMPUTER TIME IN PROBLEMS WHERE A LARGE PART OF
C THE COMPUTATION IS THE SAME FOR DIFFERENT VALUES OF IPT, SINCE IT
C AVOIDS UNNECESSARY REPITITION OF THIS COMMON COMPUTATION BY HAVING
C THE LOOP OVER IPT IN FNSET INSTEAD OF OUTSIDE FNSET.
C IF THE TEN THOUSANDS DIGIT OF IOPTN IS 1, EVEN MORE TIME CAN OFTEN BE
C SAVED IF FNSET IS WRITTEN SO THAT ALL CONSTRAINTS ARE COMPUTED IF IPT=0,
C BUT ONLY THE STANDARD (I.E. TYPE -1 OR -2) CONSTRAINTS ARE COMPUTED IF
C IPT=-1.  NOTE THAT IF THE TEN THOUSANDS DIGIT OF IOPTN IS 0, THEN IPT
C WILL BE POSITIVE WHENEVER FNSET IS CALLED, INDICATING THAT ONLY
C CONSTRAINT IPT SHOULD BE COMPUTED.
C THE DRAWBACK OF USING THIS OPTION IS THAT IN GENERAL SOME CONSTRAINT
C VALUES AND DERIVATIVES WILL BE COMPUTED UNNECESSARILY, WHICH COULD COST
C TIME IN SOME PROBLEMS.
C
C IF THE COMPILER USED FOR THIS PROGRAM WILL NOT ACCEPT VARIABLE
C DIMENSIONING AS USED HERE, ONE CAN  (1)  CHANGE ALL THE DIMENSIONS TO
C THE APPROPRIATE INTEGER CONSTANTS, WHERE IN THE DIMENSION STATEMENTS
C NPARM AND NUMGR CAN BE CONSISTENTLY REPLACED BY FIXED INTEGERS OF
C EQUAL OR GREATER VALUE, (2)  FOR EACH SUBPROGRAM EXCEPT FNSET, DELETE
C ALL ARRAY NAMES FROM THE ARGUMENT LISTS IN THE SUBROUTINE OR FUNCTION
C STATEMENT EXCEPT FUN, PTTBL, PARAM, ERROR, IWORK, AND WORK, AND DELETE
C THE CORRESPONDING ELEMENTS IN ALL CALL STATEMENTS AND FUNCTION
C SUBPROGRAM REFERENCES, AND (3)  USE AN EQUIVALENCE STATEMENT AFTER
C THE DIMENSION STATEMENT IN EACH SUBPROGRAM WITH ARRAYS DELETED FROM
C THE ARGUMENT LIST TO ASSOCIATE THE FIRST ELEMENT OF EACH DELETED
C ARRAY WITH THE APPROPRIATE ELEMENT IN IWORK OR WORK USING THE
C INFORMATION IN FUNCTION SUBPROGRAM ILOC.
C
C FOR FURTHER INFORMATION ABOUT THE ALGORITHM AND PROGRAM, SEE THE PAPER
C
C AN ODE-BASED APPROACH TO NONLINEARLY CONSTRAINED MINIMAX PROBLEMS, BY
C E. H. KAUFMAN, JR., D. J. LEEMING, AND G. D. TAYLOR, NUMERICAL
C ALGORITHMS (1995), PP. 25-37.
C
C NOTE THAT SINCE THAT PAPER WAS WRITTEN, TOLCON WAS DELETED FROM THE
C ARGUMENT LIST OF CONMAX.
C
C
C A SAMPLE DRIVER PROGRAM AND SUBROUTINE FNSET ARE INCLUDED IN THIS
C PACKAGE, AND WE NOW DISCUSS THE EXAMPLE USED THEREIN;  FOR MORE
C INFORMATION, SEE THE COMMENTS IN THESE TWO ROUTINES.
C
C THE EXAMPLE IS TO CHOOSE (DOUBLE PRECISION) PARAMETERS A, B, C, AND D
C TO MINIMIZE
C
C MAX{ MAX (|F(X,Y) - (AX+BY+C)/(DX+1)|, |(AX+BY+C)/(DX+1)|) :
C (X,Y) IN Z}
C
C SUBJECT TO THE CONSTRAINTS
C
C DX+1 .GE. EPS FOR (X,Y) IN Z,
C
C AND THE FIRST PARTIAL DERIVATIVE OF (AX+BY+C)/(DX+1) WITH RESPECT TO
C X IS .LE. 0.0 AT (X,Y) = (0.0,0.0).
C
C HERE WE ARE TAKING Z = {(0.0,0.0), (0.0,1.0), (-2.0/3.0,1.0/3.0),
C (1.0,1.0), (1.0,2.0)}, EPS = .0001, F(0.0,0.0) = .5, F(0.0,1.0) = 1.0,
C F(-2.0/3.0,1.0/3.0) = -1.0, F(1.0,1.0) =1.5, F(1.0,2.0) =-1.0,
C AND TAKING THE INITIAL GUESSES FOR THE PARAMETERS TO BE
C A = B = C = D = 0.0
C
C TO USE CONMAX, WE WRITE THIS PROBLEM AS THE OPTIMIZATION PROBLEM
C
C MINIMIZE W, SUBJECT TO
C
C |F(X,Y) - (AX+BY+C)/(DX+1)| .LE. W, (X,Y) IN Z,    (TYPE 2)
C
C            (AX+BY+C)/(DX+1) .LE. W, (X,Y) IN Z,    (TYPE 1)
C
C           -(AX+BY+C)/(DX+1) .LE. W, (X,Y) IN Z,    (TYPE 1)
C
C               -DX - 1 + EPS .LE. 0, (X,Y) IN Z,    (TYPE -1)
C
C                      A - CD .LE. 0.                (TYPE -2)
C
C ONE CAN PROVE THAT THE UNIQUE BEST VALUES ARE A = -B = C = D = 1.0,
C WITH W (= ENORM = ERROR(NUMGR+1)) = 1.0.  ONE CAN ALSO PROVE THAT
C THERE ARE LOCAL SOLUTIONS WHICH ARE NOT GLOBAL SOLUTIONS, THAT IS,
C SOLUTIONS FOR WHICH W CANNOT BE REDUCED BY SMALL CHANGES IN A, B, C,
C AND D, BUT FOR WHICH A, B, C, D CAN BE FOUND SATISFYING THE CONSTRAINTS
C AND GIVING SMALLER W.  SOME SUCH SOLUTIONS ARE GIVEN BY A = B = D = 0.0,
C C = 0.25, WITH W = 1.25, AND OTHER CHOICES WHERE THE RATIONAL FUNCTION
C REDUCES TO THE CONSTANT 0.25 AND THE COEFFICIENTS SATISFY THE CONSTRAINTS.
C WHEN THE PROGRAM IS RUN, ANY OF THESE SOLUTIONS MAY BE FOUND (UP TO A
C SMALL DISCREPANCY DUE IN PART TO ROUNDOFF), DEPENDING ON THE ACCURACY OF
C THE COMPUTER BEING USED.
C
C THE OUTPUT FOR THE SAMPLE DRIVER AND FNSET FOLLOWS.  THIS WAS RUN ON
C A MAC SE (WITH ONE MEGABYTE OF RAM) WITH D1MACH(3) SET TO 16.0D0**(-14)
C USING THE ABSOFT MACFORTRAN COMPILER (VERSION 2.4);  RUNS WITH A
C DIFFERENT MACHINE AND/OR A DIFFERENT D1MACH(3) AND/OR A DIFFERENT
C COMPILER COULD PRODUCE DIFFERENT RESULTS, ESPECIALLY CONSIDERING THE
C POSSIBILITY OF LOCAL SOLUTIONS WHICH ARE NOT GLOBALY BEST.
C
C IOPTN IS    0  NPARM IS   4  NUMGR IS  21
C
C ITLIM IS  100  IFUN IS  5  IPTB IS  6  INDM IS  2
C
C THE FUNCTION VALUES ARE
C    0.50000E+00    0.10000E+01   -0.10000E+01    0.15000E+01
C   -0.10000E+01
C
C THE POINTS ARE
C    0.00000E+00    0.00000E+00
C    0.00000E+00    0.10000E+01
C   -0.66667E+00    0.33333E+00
C    0.10000E+01    0.10000E+01
C    0.10000E+01    0.20000E+01
C
C EPS IS    0.10000E-03
C
C THE INITIAL PARAMETERS ARE
C
C   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
C
C   0.00000000000000E+00
C
C *****AFTER CONMAX ITER IS  13  LIWRK IS  178  LWRK IS   720
C
C THE FINAL PARAMETERS ARE
C
C  -0.90123453614326E-02  -0.12378422071992E-12   0.25000000000006E+00
C
C  -0.36049381446237E-01
C
C THE ERROR NORMS ARE
C
C    0.1250000000000E+01   -0.9638506185538E+00    0.1288396472843E-12
C
C THE ERRORS ARE
C
C   0.24999999999994E+00   0.75000000000006E+00  -0.12499999999999E+01
C   0.12499999999999E+01  -0.12499999999999E+01   0.25000000000006E+00
C  -0.25000000000006E+00   0.24999999999994E+00  -0.24999999999994E+00
C   0.24999999999994E+00  -0.24999999999994E+00   0.25000000000006E+00
C  -0.25000000000006E+00   0.24999999999994E+00  -0.24999999999994E+00
C  -0.99990000000000E+00  -0.99990000000000E+00  -0.10239329209642E+01
C  -0.96385061855376E+00  -0.96385061855376E+00   0.12883964728427E-12
C
C
C WE NOW DESCRIBE FOUR SUBUNITS OF CONMAX WHICH THE USER CAN CALL
C DIRECTLY IF IT IS DESIRED TO ACOMPLISH CERTAIN TASKS MORE SIMPLY
C AND QUICKLY THAN SETTING UP THE PROBLEMS FOR CONMAX.  IN EACH CASE A
C DRIVER PROGRAM (AND A SUBROUTINE FNSET IF NECESSARY) IS SUPPLIED,
C WHICH CAN BE USED BY REPLACING THE C IN COLUMN 1 OF EACH LINE BY A
C BLANK (EXCEPT CC IS REPLACED BY C) AND APPROPRIATELY MODIFYING THOSE
C STATEMENTS WHICH ARE INDICATED TO BE USER SETTABLE.  THE OPEN STATEMENT
C MAY ALSO NEED TO BE CHANGED, DEPENDING ON THE MACHINE.  OUTPUT PRODUCED
C BY THE SAMPLE DRIVER ON THE MAC SE IS ALSO PROVIDED.  ALTHOUGH CERTAIN
C ADVANTAGES (SUCH AS REDUCED STORAGE) COULD BE GAINED BY REWRITING SOME
C OF THE SUBPROGRAMS IN THE CONMAX PACKAGE, FOR SIMPLICITY THE DRIVER
C PROGRAMS ARE SET UP SO THAT THE SUBPROGRAMS IN THIS PACKAGE CAN BE USED
C AS IS, WITH NO CHANGES OTHER THAN IN THE DRIVER PROGRAMS AND (IN CASES
C (A) AND (B) BELOW) THE SUBROUTINES FNSET.  THUS IF DESIRED ONE COULD
C COMPILE AND LOAD THE ENTIRE CONMAX PACKAGE (EXCEPT FOR DRIVERS AND
C SUBROUTINES FNSET) AND USE IT AS A LIBRARY.  FOR SIMPLICITY WE ALSO DO
C NOT DESCRIBE HERE CERTAIN ADDITIONAL OPTIONS, SUCH AS A HOT START
C OPTION IN (C) AND (D), BUT MORE INFORMATION CAN BE OBTAINED FROM THE
C COMMENTS IN THE SUBPROGRAMS INVOLVED IF DESIRED.
C
C
C (A) MULLERS METHOD DERIVATIVE FREE REAL ROOT FINDING
C
C (SUBPROGRAMS INVOLVED:  MULLER, FNSET (USER SUPPLIED), ILOC, D1MACH,
C ERCMP1)
C
C GIVEN A FUNCTION F OF ONE VARIABLE (WHERE F(X) IS COMPUTED IN SUBROUTINE
C FNSET AS CONFUN(1,1), WITH X = PARAM(1)), A NONNEGATIVE TOLERANCE TOLCON,
C TWO POINTS (P1,F1) AND (PROCOR,EMIN) WITH F1 = F(P1), EMIN = F(PROCOR),
C P1 .LT. PROCOR, F1 .GT. TOLCON, AND EMIN .LT. -TOLCON, THE PROGRAM WILL
C ATTEMPT TO LOCATE A NEW PROCOR WITH NEW EMIN = F(PROCOR) AND ABS(EMIN)
C .LE. TOLCON.  IF IT FAILS TO DO THIS, THE PROGRAM WILL RETURN WITH
C PROCOR = THE LEFTMOST ABSCISSA FOUND WITH EMIN = F(PROCOR) .LT. -TOLCON.
C NOTE:  IF INSTEAD OF F1 .GT. TOLCON AND EMIN .LT. -TOLCON WE START WITH
C F1 .LT. -TOLCON AND EMIN .GT. TOLCON, THIS PROGRAM CAN STILL BE USED
C BY REPLACING F BY -F BEFORE RUNNING THE PROGRAM.
C THE SOLUTION PROCEDURE IS A MODIFICATION OF THE FOLLOWING:  BISECT THE
C INTERVAL [P1,PROCOR] TO GET A THIRD POINT, PASS A QUADRATIC POLYNOMIAL
C THROUGH THE THREE POINTS AND USE ITS UNIQUE ZERO IN [P1,PROCOR] TO
C REPLACE P1 OR PROCOR, MAINTAINING THE CONDITIONS F(LEFT ENDPOINT) .GT.
C TOLCON AND F(RIGHT ENDPOINT) .LT. -TOLCON, AND CONTINUE UNTIL A SOLUTION
C IS FOUND OR F HAS BEEN COMPUTED 5 TIMES OR THE INTERVAL LENGTH FALLS
C BELOW 100.0*B**(-ITT).  THIS PROCEDURE MAY BE ESPECIALLY USEFUL IN CASES
C WHERE F IS EXPENSIVE TO COMPUTE SINCE IT MAINTAINS A SHRINKING INTERVAL
C ABOUT THE SOLUTION, HAS A HIGHER ORDER OF CONVERGENCE THAN THE REGULA
C FALSI METHOD, AND REQUIRES NO DERIVATIVES.  THE FOLLOWING SAMPLE DRIVER
C PROGRAM AND SUBROUTINE FNSET ARE SET UP TO FIND PROCOR IN [-4.0D0,2.0D0]
C WITH ABS(F(PROCOR)) .LE. 0.001D0, WHERE F(X) = 2.0D0**(-X) - 0.5D0
C (THE EXACT SOLUTION IS PROCOR = 1.0D0, EMIN = 0.0D0).
C
C SAMPLE DRIVER AND FNSET FOR (A) MULLERS METHOD
C
C     IMPLICIT REAL*8 (A-H,O-Z)
C     DIMENSION DVEC(1),FUN(1),PTTBL(1,1),ZWORK(1),ERR1(4),
C    *PARWRK(1),IWORK(17),WORK(6)
C     OPEN(6,FILE='MULOUT')
C     DVEC(1)=1.0D0
C     ZWORK(1)=0.0D0
C     IWORK(16)=-2
CC*****BEGIN USER SETTABLE STATEMENTS 1 OF 2
C     TOLCON=1.0D-3
C     P1=-2.0D0
C     F1=3.5D0
C     PROCOR=2.0D0
C     EMIN=-0.25D0
CC*****END USER SETTABLE STATEMENTS 1 OF 2
C     WRITE(6,100)TOLCON,P1,F1,PROCOR,EMIN
C 100 FORMAT(/10H TOLCON IS,E22.13//16H INITIALLY P1 IS,E22.13,
C    *7H  F1 IS,E22.13//10H PROCOR IS,E22.13,9H  EMIN IS,E22.13)
C     CALL MULLER(0,1,1,DVEC,FUN,1,PTTBL,1,1,ZWORK,TOLCON,0,
C    *IWORK,17,WORK,6,PARWRK,ERR1,P1,F1,PROCOR,EMIN)
C     WRITE(6,200)PROCOR,EMIN
C 200 FORMAT(/23H AFTER MULLER PROCOR IS,E22.13//8H EMIN IS,
C    *E22.13)
C     STOP
C     END
C     SUBROUTINE FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
C    *INDFN,ICNTYP,CONFUN)
C     IMPLICIT REAL*8 (A-H,O-Z)
C     DIMENSION PTTBL(IPTB,INDM),PARAM(NPARM),ICNTYP(NUMGR),
C    *CONFUN(NUMGR,NPARM+1)
CC*****BEGIN USER SETTABLE STATEMENTS 2 OF 2
C     CONFUN(1,1)=2.0D0**(-PARAM(1))-0.5D0
CC*****END USER SETTABLE STATEMENTS 2 OF 2
C     RETURN
C     END
C
C OUTPUT FOR (A) MULLERS METHOD
C
C TOLCON IS   0.1000000000000E-02
C
C INITIALLY P1 IS  -0.2000000000000E+01  F1 IS   0.3500000000000E+01
C
C PROCOR IS   0.2000000000000E+01  EMIN IS  -0.2500000000000E+00
C
C AFTER MULLER PROCOR IS   0.9993746852789E+00
C
C EMIN IS   0.2167645412207E-03
C
C
C (B) ONE-DIMENSIONAL DERIVATIVE-FREE QUADRATIC SEARCH FOR A POSITIVE
C     LOCAL MINIMUM
C
C (SUBPROGRAMS INVOLVED:  SEARSL, FNSET (USER SUPPLIED), ILOC, D1MACH,
C ERCMP1, RCHMOD, CORRCT, SEARCR, MULLER, WOLFE, CONENR, HOUSE,
C DOTPRD, REFWL;  ONLY THE FIRST FIVE OF THESE ARE ACTUALLY USED)
C
C GIVEN A FUNCTION F OF ONE VARIABLE (WHERE F(X) IS COMPUTED IN SUBROUTINE
C FNSET AS CONFUN(1,1), WITH X = PARAM(1)) AND A POSITIVE NUMBER PROJCT,
C THE PROGRAM WILL ATTEMPT TO LOCATE A NEW PROJCT WITH EMIN = F(PROJCT),
C WITH THE NEW PROJCT APPROXIMATELY GIVING A LOCAL MINIMUM OF F IN
C [(OLD PROJCT)/1024, 1024*(OLD PROJCT)].  IF IT FAILS TO DO THIS, THE
C PROGRAM WILL RETURN WITH PROJCT = THE ABSCISSA FOUND WITH SMALLEST
C EMIN = F(PROJCT).  ON OUTPUT, NSRCH WILL BE THE NUMBER OF EVALUATIONS
C OF F THAT WERE DONE.  THE SOLUTION PROCEDURE IS A MODIFICATION OF THE
C FOLLOWING:  COMPUTE F(PROJCT/2), F(PROJCT), AND F(2*PROJCT), IF THE
C CONDITIONS F(MIDDLE POINT) .LE. F(LEFT POINT) AND F(MIDDLE POINT) .LE.
C F(RIGHT POINT) ARE NOT BOTH SATISFIED THEN TRY TO GET THIS BY COMPUTING
C F AT SMALLER (OR LARGER) POINTS AT MOST 3 MORE TIMES;  ONCE THE
C CONDITIONS ARE SATISFIED, ASSUMING THE POINTS ARE NOT TOO CLOSE TO BEING
C COLLINEAR, PASS A QUADRATIC POLYNOMIAL THROUGH THE THREE POINTS AND USE
C ITS UNIQUE MINIMUM IN THE INTERVAL TO REPLACE ONE OF THE ENDPOINTS WHILE
C MAINTAINING THE TWO CONDITIONS, CONTINUING UNTIL F HAS BEEN COMPUTED 4
C MORE TIMES OR THE INTERVAL LENGTH FALLS BELOW 100.0*B**(-ITT) OR THE
C POINTS BECOME NEARLY COLLINEAR.  THE FOLLOWING SAMPLE DRIVER AND
C SUBROUTINE FNSET ARE SET UP TO APPROXIMATE A SOLUTION OF THE LINE SEARCH
C PROBLEM OF MINIMIZING G((6.0D0,2.0D0) + PROJCT*(-2.0D0,-1.0D0)), WHERE
C G(U,V) = 3.0D0*ABS(U) + 2.0D0*ABS(V).  WE START WITH PROJCT = 1.0D0,
C THEN RUN THE PROGRAM AGAIN STARTING WITH THE RESULT OF THE FIRST RUN.
C (THE EXACT SOLUTION IS PROJCT = 3.0D0, EMIN = 2.0D0;  CONVERGENCE IS
C RATHER SLOW, MAINLY BECAUSE F IS NOT DIFFERENTIABLE AT THE MINIMUM.)
C
C SAMPLE DRIVER AND FNSET FOR (B) ONE-DIMENSIONAL SEARCH
C
C     IMPLICIT REAL*8 (A-H,O-Z)
C     DIMENSION X(2),FUN(1),PTTBL(1,1),PARAM(1),ERROR(4),IACT(1),
C    *IWORK(17),WORK(42),ERR1(4),PARPRJ(1),PARSER(1)
C     OPEN(6,FILE='SEROUT')
C     SPCMN=D1MACH(3)
C     TOL1=100.0D0*SPCMN
C     TOLCON=SQRT(SPCMN)
C     IACT(1)=1
C     IWORK(7)=1
C     PRJLIM=1.0D0/SPCMN
C     PARAM(1)=0.0D0
C     X(1)=1.0D0
CC*****BEGIN USER SETTABLE STATEMENTS 1 OF 2
C     PROJCT=1.0D0
CC*****END USER SETTABLE STATEMENTS 1 OF 2
C     WRITE(6,100)PROJCT
C 100 FORMAT(/20H INITIALLY PROJCT IS,E22.13)
C     CALL SEARSL(0,1,1,PRJLIM,TOL1,X,FUN,1,PTTBL,1,1,PARAM,ERROR,
C    *2.0D0,1,IACT,0,1.0D0,TOLCON,2.0D0,0,0,IWORK,17,WORK,42,
C    *ERR1,PARPRJ,PROJCT,EMIN,EMIN1,PARSER,NSRCH)
C     WRITE(6,200)PROJCT,EMIN,NSRCH
C 200 FORMAT(/23H AFTER SEARSL PROJCT IS,E22.13//8H EMIN IS,
C    *E22.13,10H  NSRCH IS,I4)
C     STOP
C     END
C     SUBROUTINE FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
C    *INDFN,ICNTYP,CONFUN)
C     IMPLICIT REAL*8 (A-H,O-Z)
C     DIMENSION PTTBL(IPTB,INDM),PARAM(NPARM),ICNTYP(NUMGR),
C    *CONFUN(NUMGR,NPARM+1)
CC*****BEGIN USER SETTABLE STATEMENTS 2 OF 2
C     U=6.0D0+PARAM(1)*(-2.0D0)
C     V=2.0D0+PARAM(1)*(-1.0D0)
C     CONFUN(1,1)=3.0D0*ABS(U)+2.0D0*ABS(V)
CC*****END USER SETTABLE STATEMENTS 2 OF 2
C     RETURN
C     END
C
C OUTPUT 1 FOR (B) ONE-DIMENSIONAL SEARCH
C
C INITIALLY PROJCT IS   0.1000000000000E+01
C
C AFTER SEARSL PROJCT IS   0.2956250000000E+01
C
C EMIN IS   0.2175000000000E+01  NSRCH IS   8
C
C OUTPUT 2 FOR (B) ONE-DIMENSIONAL SEARCH
C
C INITIALLY PROJCT IS   0.2956250000000E+01
C
C AFTER SEARSL PROJCT IS   0.3010732751581E+01
C
C EMIN IS   0.2085862012645E+01  NSRCH IS   7
C
C
C (C) FREE-VARIABLE INEQUALITY-CONSTRAINED LINEAR PROGRAMMING
C
C (SUBPROGRAMS INVOLVED:  SLNPRO, D1MACH, SJELIM)
C
C GIVEN POSITIVE INTEGERS M AND N WITH M .GE. N, AND A MATRIX V, THIS
C PROGRAM WILL ATTEMPT TO SOLVE THE LINEAR PROGRAMMING PROBLEM
C MAXIMIZE  -V(M+1,1)*X(1)-...-V(M+1,N)*X(N)
C SUBJECT TO  V(I,1)*X(1)+...+V(I,N)*X(N) .LE. V(I,N+1) FOR I=1,...,M.
C ON OUTPUT, INDIC WILL BE AN ERROR FLAG WHOSE VALUE WILL BE 0 FOR A
C NORMAL SOLUTION, NEGATIVE FOR A POSSIBLY INACCURATE SOLUTION, AND
C POSITIVE FOR A PROBABLE FAILURE.  THE METHOD IS AN ENHANCED VERSION OF
C THAT IN
C AVDEYEVA, L. I. AND ZUKHOVITSKIY, S. I., LINEAR AND CONVEX PROGRAMMING,
C SAUNDERS, PHILADELPHIA, 1966.
C THE FOLLOWING SAMPLE DRIVER IS SET UP TO MAXIMIZE -Y, SUBJECT TO
C X + Y .GE. 2.0D0 (I.E. -X - Y .LE. -2.0D0) AND X - Y .LE. 4.0DO.
C (THE EXACT SOLUTION IS X = 3.0D0, Y = -1.0D0, WITH MAXIMUM OBJECTIVE
C FUNCTION VALUE 1.0D0.)
C
C SAMPLE DRIVER FOR (C) LINEAR PROGRAMMING
C
C     IMPLICIT REAL*8 (A-H,O-Z)
CC THE MINIMUM DIMENSIONS ARE V(NUMGR+2*NPARM+1,NPARM+2), X(NPARM+1),
CC IYCCT(NPARM+1), Y(NUMGR+2*NPARM), IXRCT(NUMGR+2*NPARM),
CC IYRCT(NUMGR+2*NPARM), WHERE NPARM .GE. N AND NUMGR .GE. M. THE FIRST
CC DIMENSION OF V MUST BE EXACTLY NUMGR+2*NPARM+1.
CC*****BEGIN USER SETTABLE STATEMENTS 1 OF 1
C     DIMENSION V(7,4),X(3),IYCCT(3),Y(6),IXRCT(6),IYRCT(6)
C     N=2
C     M=2
C     V(1,1)=-1.0D0
C     V(1,2)=-1.0D0
C     V(1,3)=-2.0D0
C     V(2,1)=1.0D0
C     V(2,2)=-1.0D0
C     V(2,3)=4.0D0
C     V(3,1)=0.0D0
C     V(3,2)=1.0D0
C     NPARM=N
C     NUMGR=M
CC*****END USER SETTABLE STATEMENTS 1 OF 1
C     MP1=M+1
C     NP1=N+1
C     V(MP1,NP1)=0.0D0
C     IYRCT(1)=-1
C     OPEN(6,FILE='LPOUT')
C     WRITE(6,100)M,N
C 100 FORMAT(/10H THERE ARE,I5,17H  CONSTRAINTS AND,I5,
C    *11H  VARIABLES//32H THE CONSTRAINT COEFFICIENTS AND,
C    *16H RIGHT SIDES ARE)
C     DO 300 I=1,M
C       WRITE(6,200)(V(I,J),J=1,NP1)
C 200   FORMAT(/(3E22.13))
C 300   CONTINUE
C     WRITE(6,400)(V(MP1,J),J=1,N)
C 400 FORMAT(/40H THE NEGATIVES OF THE OBJECTIVE FUNCTION,
C    *17H COEFFICIENTS ARE//(3E22.13))
C     CALL SLNPRO(V,M,N,IYRCT,Y,IXRCT,IYCCT,NPARM,NUMGR,X,INDIC)
C     WRITE(6,500)INDIC,(X(I),I=1,N)
C 500 FORMAT(/31H AFTER SLNPRO THE ERROR FLAG IS,I4,
C    *19H  THE VARIABLES ARE//(3E22.13))
C     WRITE(6,600)V(MP1,NP1)
C 600 FORMAT(/32H THE OBJECTIVE FUNCTION VALUE IS,E22.13)
C     STOP
C     END
C
C OUTPUT FOR (C) LINEAR PROGRAMMING
C
C THERE ARE    2  CONSTRAINTS AND    2  VARIABLES
C
C THE CONSTRAINT COEFFICIENTS AND RIGHT SIDES ARE
C
C  -0.1000000000000E+01  -0.1000000000000E+01  -0.2000000000000E+01
C
C   0.1000000000000E+01  -0.1000000000000E+01   0.4000000000000E+01
C
C THE NEGATIVES OF THE OBJECTIVE FUNCTION COEFFICIENTS ARE
C
C   0.0000000000000E+00   0.1000000000000E+01
C
C AFTER SLNPRO THE ERROR FLAG IS   0  THE VARIABLES ARE
C
C   0.3000000000000E+01  -0.1000000000000E+01
C
C THE OBJECTIVE FUNCTION VALUE IS   0.1000000000000E+01
C
C
C (D) LEAST-DISTANCE QUADRATIC PROGRAMMING
C
C (SUBPROGRAMS INVOLVED:  WOLFE, D1MACH, ILOC, CONENR, HOUSE, DOTPRD,
C REFWL)
C
C GIVEN POSITIVE INTEGERS M AND N, AND A MATRIX PMAT, THIS PROGRAM WILL
C ATTEMPT TO LOCATE AN N-DIMENSIONAL POINT WPT IN THE POLYHEDRON
C DETERMINED BY THE INEQUALITIES
C PMAT(1,J)*WPT(1)+...+PMAT(N,J)*WPT(N)+PMAT(N+1,J) .LE. 0.0 FOR J=1,...,M
C WHOSE DISTANCE WDIST FROM THE ORIGIN IS MINIMIZED.  ON OUTPUT, JFLAG
C WILL BE AN ERROR FLAG WHOSE VALUE WILL BE 0 FOR A NORMAL SOLUTION AND
C POSITIVE FOR A LIKELY FAILURE.  THE METHOD IS AN ENHANCED VERSION OF
C THAT IN
C WOLFE, PHILIP, FINDING THE NEAREST POINT IN A POLYTOPE, MATHEMATICAL
C PROGRAMMING 11 (1976), 128-149.
C THE FOLLOWING SAMPLE DRIVER IS SET UP TO FIND THE NEAREST POINT TO
C THE ORIGIN IN THE POLYHEDRON DEFINED BY X + Y + Z .GE. 2.0D0 (I.E.
C -X - Y - Z + 2.0D0 .LE. 0.0D0) AND Z .GE. 1.0D0 (I.E. -Z + 1.0D0 .LE.
C 0.0D0).  (THE EXACT SOLUTION IS (X,Y,Z) = (0.5D0,0.5D0,1.0D0) WITH
C DISTANCE SQRT(1.5D0) FROM THE ORIGIN.)
C
C SAMPLE DRIVER FOR (D) LEAST-DISTANCE QUADRATIC PROGRAMMING
C
C     IMPLICIT REAL*8 (A-H,O-Z)
CC THE MINIMUM DIMENSIONS ARE PMAT(NPARM+1,NUMGR), PMAT1(NPARM+1,NUMGR),
CC WPT(NPARM), ICOR(NPARM+1), R(NPARM+1), PTNR(NPARM+1), COEF(NUMGR),
CC WCOEF(NUMGR), IWORK(4*NUMGR+5*NPARM+3), WORK(2*NPARM**2+4*NUMGR*NPARM
CC +9*NUMGR+22*NPARM+10), WHERE NPARM .GE. N AND NUMGR .GE. M.  THE FIRST
CC DIMENSIONS OF PMAT AND PMAT1 MUST BE EXACTLY NPARM+1.
CC*****BEGIN USER SETTABLE STATEMENTS 1 OF 1
C     DIMENSION PMAT(4,2),PMAT1(4,2),WPT(3),ICOR(4),R(4),PTNR(4),
C    *COEF(2),WCOEF(2),IWORK(26),WORK(136)
C     N=3
C     M=2
C     PMAT(1,1)=-1.0D0
C     PMAT(2,1)=-1.0D0
C     PMAT(3,1)=-1.0D0
C     PMAT(4,1)=2.0D0
C     PMAT(1,2)=0.0D0
C     PMAT(2,2)=0.0D0
C     PMAT(3,2)=-1.0D0
C     PMAT(4,2)=1.0D0
C     NPARM=N
C     NUMGR=M
CC*****END USER SETTABLE STATEMENTS 1 OF 1
C     LIWRK=4*NUMGR+5*NPARM+3
C     LWRK=2*NPARM**2+4*NUMGR*NPARM+9*NUMGR+22*NPARM+10
C     MP1=M+1
C     NP1=N+1
C     OPEN(6,FILE='QPOUT')
C     WRITE(6,100)M,N
C 100 FORMAT(/10H THERE ARE,I5,16H  BOUNDARIES AND,I5,
C    *12H  DIMENSIONS//30H THE BOUNDARY COEFFICIENTS ARE)
C     DO 300 J=1,M
C       WRITE(6,200)(PMAT(I,J),I=1,NP1)
C 200   FORMAT(/(3E22.13))
C 300   CONTINUE
C     CALL WOLFE(N,M,PMAT,0,S,NCOR,ICOR,IWORK,LIWRK,WORK,LWRK,
C    *R,COEF,PTNR,PMAT1,NPARM,NUMGR,WCOEF,WPT,WDIST,NMAJ,NMIN,
C    *JFLAG)
C     WRITE(6,400)JFLAG,WDIST,(WPT(I),I=1,N)
C 400 FORMAT(/30H AFTER WOLFE THE ERROR FLAG IS,I4//
C    *32H THE DISTANCE FROM THE ORIGIN IS,E22.13//
C    *26H THE POINT HAS COORDINATES//(3E22.13))
C     STOP
C     END
C
C OUTPUT FOR (D) LEAST-DISTANCE QUADRATIC PROGRAMMING
C
C THERE ARE    2  BOUNDARIES AND    3  DIMENSIONS
C
C THE BOUNDARY COEFFICIENTS ARE
C
C  -0.1000000000000E+01  -0.1000000000000E+01  -0.1000000000000E+01
C   0.2000000000000E+01
C
C   0.0000000000000E+00   0.0000000000000E+00  -0.1000000000000E+01
C   0.1000000000000E+01
C
C AFTER WOLFE THE ERROR FLAG IS   0
C
C THE DISTANCE FROM THE ORIGIN IS   0.1224744871392E+01
C
C THE POINT HAS COORDINATES
C
C   0.5000000000000E+00   0.5000000000000E+00   0.1000000000000E+01
C
C
C**********END OF USERS MANUAL FOR CONMAX.
C
C
C THIS IS A TEST DRIVER PROGRAM FOR CONMAX.  FOR A DESCRIPTION OF
C CONMAX, PLEASE SEE THE CONMAX USERS GUIDE, WHICH APPEARS AT THE
C BEGINNING OF THIS PACKAGE.  FOR MORE INFORMATION ABOUT THE
C EXAMPLE WHICH IS SET UP IN THIS DRIVER PROGRAM AND IN SUBROUTINE
C FNSET, PLEASE SEE THE COMMENTS IN THESE TWO ROUTINES AS WELL AS
C THE COMMENTS IN THE AFOREMENTIONED USERS GUIDE.
C
C THIS TEST DRIVER PROGRAM AND FNSET ARE SET UP TO CHOOSE REAL (DOUBLE
C PRECISION) PARAMETERS A, B, C, AND D TO MINIMIZE
C
C MAX{ MAX (|F(X,Y) - (AX+BY+C)/(DX+1)|, |(AX+BY+C)/(DX+1)|) :
C (X,Y) IN Z}
C
C SUBJECT TO THE CONSTRAINTS
C
C DX+1 .GE. EPS FOR (X,Y) IN Z,
C
C AND THE FIRST PARTIAL DERIVATIVE OF (AX+BY+C)/(DX+1) WITH RESPECT TO
C X IS .LE. 0.0 AT (X,Y) = (0.0,0.0).
C
C HERE WE ARE TAKING Z = {(0.0,0.0), (0.0,1.0), (-2.0/3.0,1.0/3.0),
C (1.0,1.0), (1.0,2.0)}, EPS = .0001, F(0.0,0.0) = .5, F(0.0,1.0) = 1.0,
C F(-2.0/3.0,1.0/3.0) = -1.0, F(1.0,1.0) =1.5, F(1.0,2.0) =-ONE,
C AND TAKING THE INITIAL GUESSES FOR THE PARAMETERS TO BE
C A = B = C = D = 0.0
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(5),PTTBL(6,2),IWORK(178),WORK(720),PARAM(4),
     *ERROR(24)
C
C*****MAC INSERT
C     OPEN(6,FILE='TSTOT')
C*****END MAC INSERT
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      THREE=ONE+TWO
      NREAD=I1MACH(1)
      NWRIT=I1MACH(2)
C
C SET PARAMETERS FOR CONMAX.
C
C SET IOPTN=0 SINCE NO EXTRA OPTIONS ARE TO BE USED.
      IOPTN=0
C
C SET NPARM=4 SINCE THERE ARE 4 PARAMETERS (VARIABLES) A, B, C, AND D.
      NPARM=4
C
C SET NUMGR=21 SINCE THERE ARE 21 CONSTRAINTS (5 OF TYPE 2, 10 OF TYPE 1,
C 5 OF TYPE -1, AND ONE OF TYPE -2).
      NUMGR=21
C
C SET ITLIM=100, OR WHATEVER LIMIT IS DESIRED ON THE NUMBER OF ITERATIONS.
      ITLIM=100
C
C SET IFUN=5 (OR GREATER) SINCE THERE ARE 5 TYPE 2 CONSTRAINTS, AND USE
C THIS NUMBER AS THE DIMENSION OF FUN ABOVE.
      IFUN=5
C
C SET IPTB=6 (OR GREATER) AND SET INDM=2 (OR GREATER), SINCE THE GREATEST
C FIRST SUBSCRIPT WE WILL USE IN PTTBL IS 6, AND THE GREATEST SECOND
C SUBSCRIPT WE WILL USE IN PTTBL IS 2.  WE USE THESE NUMBERS TO DIMENSION
C PTTBL ABOVE.  NOTE THAT IT IS ESSENTIAL THAT THE FIRST DIMENSION OF
C PTTBL BE EXACTLY IPTB.
      IPTB=6
      INDM=2
C
C SET LIWRK=178 (OR GREATER), AND USE THIS NUMBER TO DIMENSION LIWRK
C ABOVE, BECAUSE OF THE COMPUTATION 7*21 + 7*4 + 3 = 178 (SEE CONMAX
C USERS GUIDE FOR AN EXPLANATION OF THIS AND OF LWRK BELOW).
      LIWRK=178
C
C SET LWRK=720 (OR GREATER), AND USE THIS NUMBER TO DIMENSION LWRK ABOVE,
C BECAUSE OF THE COMPUTATION 2*4**2 + 4*21*4 + 11*21 + 27*4 + 13 = 720.
      LWRK=720
C
C THE DIMENSION OF PARAM ABOVE MUST BE NPARM (I.E. 4) OR GREATER, AND THE
C DIMENSION OF ERROR ABOVE MUST BE NUMGR+3 (I.E. 24) OR GREATER.
C
C SET THE VALUES OF THE FUNCTION F.
      FUN(1)=ONE/TWO
      FUN(2)=ONE
      FUN(3)=-ONE
      FUN(4)=THREE/TWO
      FUN(5)=-ONE
C
C SET THE COORDINATES OF THE FIVE POINTS.
      PTTBL(1,1)=ZERO
      PTTBL(1,2)=ZERO
      PTTBL(2,1)=ZERO
      PTTBL(2,2)=ONE
      PTTBL(3,1)=-TWO/THREE
      PTTBL(3,2)=ONE/THREE
      PTTBL(4,1)=ONE
      PTTBL(4,2)=ONE
      PTTBL(5,1)=ONE
      PTTBL(5,2)=TWO
C
C PUT EPS IN PTTBL(6,1) FOR TRANSMITTAL TO FNSET.  THIS IS WHY WE NEEDED
C IPTB TO BE AT LEAST 6.
      EPS=(5*TWO)**(-4)
      PTTBL(6,1)=EPS
C
C SET THE INITIAL GUESSES FOR THE PARAMETERS.
      PARAM(1)=ZERO
      PARAM(2)=ZERO
      PARAM(3)=ZERO
      PARAM(4)=ZERO
C
C WRITE THE INITIAL DATA.
      WRITE(NWRIT,100)IOPTN,NPARM,NUMGR,ITLIM,IFUN,IPTB,INDM
  100 FORMAT(/9H IOPTN IS,I5,10H  NPARM IS,I4,10H  NUMGR IS,I4//
     *9H ITLIM IS,I5,9H  IFUN IS,I3,9H  IPTB IS,I3,9H  INDM IS,I3)
      WRITE(NWRIT,200)(FUN(I),I=1,5)
  200 FORMAT(/24H THE FUNCTION VALUES ARE/(4E15.5))
      WRITE(NWRIT,300)
  300 FORMAT(/15H THE POINTS ARE)
      DO 500 I=1,5
        WRITE(NWRIT,400)(PTTBL(I,J),J=1,INDM)
  400   FORMAT(2E15.5)
  500   CONTINUE
      WRITE(NWRIT,600)EPS
  600 FORMAT(/7H EPS IS,E15.5)
      WRITE(NWRIT,700)(PARAM(J),J=1,NPARM)
  700 FORMAT(/27H THE INITIAL PARAMETERS ARE/(/3E23.14))
C
C NOW CALL CONMAX.
      CALL CONMAX(IOPTN,NPARM,NUMGR,ITLIM,FUN,IFUN,PTTBL,IPTB,
     *INDM,IWORK,LIWRK,WORK,LWRK,ITER,PARAM,ERROR)
C
C WRITE THE OUTPUT.
C NOTE THAT WE HAVE DEFERRED WRITING LIWRK AND LWRK UNTIL AFTER CALLING
C CONMAX SINCE CONMAX WILL CHANGE THEM TO THE NEGATIVE OF THE SMALLEST
C ALLOWABLE VALUES AND RETURN IF THEY WERE TOO SMALL.
      WRITE(NWRIT,800)ITER,LIWRK,LWRK
  800 FORMAT(/26H *****AFTER CONMAX ITER IS,I4,10H  LIWRK IS,I5,
     *9H  LWRK IS,I6)
      WRITE(NWRIT,900)(PARAM(J),J=1,NPARM)
  900 FORMAT(/25H THE FINAL PARAMETERS ARE/(/3E23.14))
      WRITE(NWRIT,1000)ERROR(NUMGR+1),ERROR(NUMGR+2),ERROR(NUMGR+3),
     *(ERROR(I),I=1,NUMGR)
 1000 FORMAT(/20H THE ERROR NORMS ARE//3E23.13//
     *15H THE ERRORS ARE//(3E23.14))
      STOP
      END
      SUBROUTINE FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *INDFN,ICNTYP,CONFUN)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PTTBL(IPTB,INDM),PARAM(NPARM),ICNTYP(NUMGR),
     *CONFUN(NUMGR,NPARM+1)
C
C THIS IS THE SUBROUTINE FNSET FOR THE EXAMPLE DISCUSSED IN THE CONMAX
C USERS GUIDE.
C
C SET PRECISION DEPENDENT CONSTANTS.
      ONE=1.0D0
      ZERO=ONE-ONE
C
C WE BREAK FNSET INTO SECTIONS BASED ON THE VALUE OF IPT, THAT IS, ON
C WHICH CONSTRAINT IS BEING SET.
      IF(IPT-5)300,300,100
  100 IF(IPT-15)600,600,200
  200 IF(IPT-20)1100,1100,1300
C
C HERE IPT .LE. 5 AND WE SET A CONSTRAINT OF THE FORM
C ABS(F(X,Y) - (AX+BY+C)/(DX+1)) .LE. W.
C NOTE THAT SINCE THIS IS A TYPE 2 CONSTRAINT WE DO NOT NEED TO DEAL
C WITH THE ABSOLUTE VALUE OR THE F(X,Y) HERE.
  300 ICNTYP(IPT)=2
      A=PARAM(1)
      B=PARAM(2)
      C=PARAM(3)
      D=PARAM(4)
      X=PTTBL(IPT,1)
      Y=PTTBL(IPT,2)
      P=A*X+B*Y+C
      Q=D*X+ONE
      CONFUN(IPT,1)=P/Q
      IF(INDFN)400,400,500
C
  400 RETURN
C
C HERE IPT .LE. 5 AND INDFN=1, AND WE SET THE PARTIAL DERIVATIVES.
  500 CONFUN(IPT,2)=X/Q
      CONFUN(IPT,3)=Y/Q
      CONFUN(IPT,4)=ONE/Q
      CONFUN(IPT,5)=-P*X/(Q*Q)
      RETURN
C
C HERE 6 .LE. IPT .LE. 15 AND IF IPT IS EVEN WE SET THE CONSTRAINT
C (AX+BY+C)/(DX+1) .LE. W, WHICH IS HALF OF THE CONSTRAINT
C ABS((AX+BY+C)/(DX+1)) .LE. W, WHILE IF IPT IS ODD WE SET THE CONSTRAINT
C -(AX+BY+C)/(DX+1) .LE. W, WHICH IS THE OTHER HALF OF THE CONSTRAINT
C ABS((AX+BY+C)/(DX+1)) .LE. W.
  600 ICNTYP(IPT)=1
      II=(IPT-4)/2
      A=PARAM(1)
      B=PARAM(2)
      C=PARAM(3)
      D=PARAM(4)
      X=PTTBL(II,1)
      Y=PTTBL(II,2)
      P=A*X+B*Y+C
      Q=D*X+ONE
      IREM=IPT-4-2*II
      IF(IREM)700,700,900
C
C HERE 6 .LE. IPT .LE. 15 AND IPT IS EVEN.
  700 CONFUN(IPT,1)=P/Q
      IF(INDFN)400,400,800
  800 CONFUN(IPT,2)=X/Q
      CONFUN(IPT,3)=Y/Q
      CONFUN(IPT,4)=ONE/Q
      CONFUN(IPT,5)=-P*X/(Q*Q)
      RETURN
C
C HERE 6 .LE. IPT .LE. 15 AND IPT IS ODD.
  900 CONFUN(IPT,1)=-P/Q
      IF(INDFN)400,400,1000
 1000 CONFUN(IPT,2)=-X/Q
      CONFUN(IPT,3)=-Y/Q
      CONFUN(IPT,4)=-ONE/Q
      CONFUN(IPT,5)=P*X/(Q*Q)
      RETURN
C
C HERE 16 .LE. IPT .LE. 20 AND WE SET A CONSTRAINT OF THE FORM
C -DX - 1.0 + EPS .LE. 0.0
 1100 ICNTYP(IPT)=-1
      D=PARAM(4)
      EPS=PTTBL(6,1)
      II=IPT-15
      X=PTTBL(II,1)
      CONFUN(IPT,1)=-D*X-ONE+EPS
      IF(INDFN)400,400,1200
 1200 CONFUN(IPT,2)=ZERO
      CONFUN(IPT,3)=ZERO
      CONFUN(IPT,4)=ZERO
      CONFUN(IPT,5)=-X
      RETURN
C
C HERE IPT=21 AND WE SET THE CONSTRAINT
C (PARTIAL DERIVATIVE OF (AX+BY+C)/(DX+1) WITH RESPECT TO X AT
C (X,Y) = (0.0,0.0)) .LE. 0.0,
C I.E. A - CD .LE. 0.0
 1300 ICNTYP(IPT)=-2
      A=PARAM(1)
      C=PARAM(3)
      D=PARAM(4)
      CONFUN(IPT,1)=A-C*D
      IF(INDFN)400,400,1400
 1400 CONFUN(IPT,2)=ONE
      CONFUN(IPT,3)=ZERO
      CONFUN(IPT,4)=-D
      CONFUN(IPT,5)=-C
      RETURN
      END
C
C
C*****END OF SAMPLE LISTING, START OF CONMAX SUBPROGRAMS
C
C
      SUBROUTINE CONMAX(IOPTN,NPARM,NUMGR,ITLIM,FUN,IFUN,PTTBL,
     *IPTB,INDM,IWORK,LIWRK,WORK,LWRK,ITER,PARAM,ERROR)
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),ERROR(NUMGR+3),
     *PARAM(NPARM),IWORK(LIWRK),WORK(LWRK)
C
C
C********** COPYRIGHT 1996 EDWIN H. KAUFMAN JR., DAVID J. LEEMING,
C********** GERALD D. TAYLOR
C********** THE AUTHORS GRATEFULLY ACKNOWLEDGE THE ASSISTANCE OF
C********** CENTRAL MICHIGAN UNIVERSITY, THE UNIVERSITY OF VICTORIA
C********** (CANADA), AND COLORADO STATE UNIVERSITY.
C********** PERMISSION TO USE, COPY, MODIFY, AND DISTRIBUTE THIS
C********** SOFTWARE FOR ANY PURPOSE WITHOUT FEE IS HEREBY GRANTED,
C********** PROVIDED THAT THIS ENTIRE NOTICE IS INCLUDED IN ANY
C********** SOFTWARE WHICH IS OR INCLUDES A COPY OR MODIFICATION OF
C********** THIS SOFTWARE AND IN ALL COPIES OF THE SUPPORTING
C********** DOCUMENTATION FOR SUCH SOFTWARE.
C********** THIS SOFTWARE IS PROVIDED "AS IS", WITHOUT EXPRESS OR
C********** IMPLIED WARRANTY.  IN PARTICULAR, NEITHER THE AUTHORS NOR
C********** THEIR UNIVERSITIES MAKE ANY REPRESENTATION OR WARRANTY OF
C********** ANY KIND CONCERNING THE MERCHANTIBILITY OF THIS SOFTWARE
C********** OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
C
C
C PLEASE SEE THE USERS GUIDE FOR CONMAX AT THE BEGINNING OF THIS
C PACKAGE FOR MORE INFORMATION ABOUT THE USE OF THESE SUBPROGRAMS.
C
C
C CHECK TO SEE IF THE DIMENSIONS LIWRK AND LWRK ARE LARGE ENOUGH.  IF
C EITHER IS NOT, REPLACE IT BY THE NEGATIVE OF ITS CORRECT MINIMUM VALUE
C AND RETRUN.
      JIWRK=7*NUMGR+7*NPARM+3
      JWRK=2*NPARM**2+4*NUMGR*NPARM+11*NUMGR+27*NPARM+13
      IF(LIWRK-JIWRK)10,20,20
   10 LIWRK=-JIWRK
      IF(LWRK-JWRK)30,40,40
   20 IF(LWRK-JWRK)30,50,50
   30 LWRK=-JWRK
   40 RETURN
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
   50 ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
C     NWRIT=I1MACH(2)
      SPCMN=D1MACH(3)
C
C INITIALIZE SOME OTHER PARAMETERS.
      NPAR1=NPARM+1
      ISUCC=0
      ITER=0
      ITERSL=0
      ITLIM1=ITLIM
      ENCHG=ZERO
      ILC02=ILOC(2,NPARM,NUMGR)
      ILC06=ILOC(6,NPARM,NUMGR)
      ILC08=ILOC(8,NPARM,NUMGR)
      ILC11=ILOC(11,NPARM,NUMGR)
      ILC12=ILOC(12,NPARM,NUMGR)
      ILC13=ILOC(13,NPARM,NUMGR)
      ILC14=ILOC(14,NPARM,NUMGR)
      ILC15=ILOC(15,NPARM,NUMGR)
      ILC17=ILOC(17,NPARM,NUMGR)
      ILC20=ILOC(20,NPARM,NUMGR)
      ILC21=ILOC(21,NPARM,NUMGR)
      ILC22=ILOC(22,NPARM,NUMGR)
      ILC24=ILOC(24,NPARM,NUMGR)
      ILC25=ILOC(25,NPARM,NUMGR)
      ILC26=ILOC(26,NPARM,NUMGR)
      ILC27=ILOC(27,NPARM,NUMGR)
      ILC29=ILOC(29,NPARM,NUMGR)
      ILC30=ILOC(30,NPARM,NUMGR)
      ILC31=ILOC(31,NPARM,NUMGR)
      ILC33=ILOC(33,NPARM,NUMGR)
      ILC35=ILOC(35,NPARM,NUMGR)
      ILC40=ILOC(40,NPARM,NUMGR)
      ILC42=ILOC(42,NPARM,NUMGR)
      ILC44=ILOC(44,NPARM,NUMGR)
      ILC46=ILOC(46,NPARM,NUMGR)
C
C IF THE TENS DIGIT OF IOPTN IS 1, SET KNTSM TO 0 AND GET ENCSM
C FROM WORK(1) AND LIMSM FROM IWORK(1).
      IOPTEN=(IOPTN-(IOPTN/100)*100)/10
      IF(IOPTEN)53,53,52
   52 KNTSM=0
      ENCSM=WORK(1)
      LIMSM=IWORK(1)
C
C IF THE HUNDREDS DIGIT OF IOPTN IS 1 OR 3, SET NSTEP = IWORK(2),
C AND OTHERWISE SET NSTEP TO ITS DEFAULT VALUE OF 1.
   53 IOPHUN=(IOPTN-(IOPTN/1000)*1000)/100
      IF(IOPHUN-(IOPHUN/2)*2)55,55,54
   54 NSTEP=IWORK(2)
      GO TO 56
   55 NSTEP=1
C
C IF THE HUNDREDS DIGIT OF IOPTN IS 2 OR 3, SET TOLCON = WORK(2),
C AND OTHERWISE SET TOLCON TO ITS DEFAULT VALUE OF SQRT(SPCMN).
   56 IF(IOPHUN-2)58,57,57
   57 TOLCON=WORK(2)
      GO TO 60
   58 TOLCON=SQRT(SPCMN)
C
C IN THIS VERSION OF CONMAX WE SET THE LINEAR CONSTRAINT TOLERANCE
C EQUAL TO THE NONLINEAR CONSTRAINT TOLERANCE.
   60 TOLLIN=TOLCON
C
C SET IRK=1 IF THE THOUSANDS DIGIT OF IOPTN IS 0 AND OTHERWISE SET IRK=0.
      IOPTHO=(IOPTN-(IOPTN/10000)*10000)/1000
      IF(IOPTHO)100,100,120
  100 IRK=1
      GO TO 200
  120 IRK=0
C
C COMPUTE THE TEN THOUSANDS DIGIT OF IOPTN FOR LATER USE.
  200 IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
C
C SET IPHSE=-1 TO INDICATE WE HAVE NOT CHECKED TYPE -1 FEASIBILITY YET.
      IPHSE=-1
C SET RCHDWN = THE NUMBER OF LENGTHS OF PROJCT IN RKSACT (OR NUMBER OF
C LENGTHS OF BNDLGT IN SETU1) WE WILL GO BELOW ERROR(NUMGR+1) TO DECLARE
C A PRIMARY CONSTRAINT TO BE ACTIVE.
      RCHDWN=TWO
      RCHDNK=RCHDWN
C SET RCHIN = THE NUMBER OF LENGTHS OF PROJCT (OR BNDLGT) WE WILL GO
C BELOW 0.0 TO DECLARE A TYPE -2 CONSTRAINT TO BE ACTIVE.
      RCHIN=TWO
C SET A NORMAL VALUE FOR NUMLIM FOR USE IN SLPCON.
      NUMLIM=11
C
C END OF PRELIMINARY SECTION.  THE STATEMENTS ABOVE THIS POINT WILL NOT
C BE EXECUTED AGAIN IN THIS CALL TO CONMAX.
C
C
C CALL ERCMP1 WITH ICNUSE=0 TO COMPUTE THE ERRORS, ERROR NORMS, AND ICNTYP.
C WE TAKE IPHSE AS 0 SO ALL CONSTRAINTS WILL BE COMPUTED BY FNSET IN CASE
C THE TEN THOUSANDS DIGIT OF IOPTN IS 1.
C THIS IS ONE OF ONLY TWO PLACES IN THE PROGRAM WHERE WE CALL ERCMP1 WITH
C ICNUSE=0, THE OTHER BEING STATEMENT 1415 BELOW..
  500 CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,PARAM,
     *0,0,IWORK,LIWRK,WORK(ILC08),IWORK(ILC17),IPMAX,ISMAX,ERROR)
C IF ITLIM=0 WE RETURN.
      IF(ITLIM)510,510,520
  510 RETURN
C
C COMPUTE ITYP2, ITYP1, ITYPM1, AND ITYPM2 AS THE NUMBER OF CONSTRAINTS  OF
C TYPE 2 (I.E. PRIMARY, ABS(FUN(I)-CONFUN(I,1)) .LE. W) OR 1 (I.E. PRIMARY,
C CONFUN(I,1) .LE. W) OR -1 (I.E. STANDARD LINEAR, CONFUN(I,1) .LE. 0.0)
C OR -2 (I.E. STANDARD NONLINEAR) RESPECTIVELY.
  520 ITYP2=0
      ITYP1=0
      ITYPM1=0
      ITYPM2=0
C NOTE THAT ARRAYS NOT IN THE CALLING SEQUENCE FOR CONMAX ARE ACCESSED
C THROUGH THEIR LOCATION IN IWORK OR WORK.  CONMAX IS THE ONLY
C SUBROUTINE IN WHICH THIS IS NECESSARY.
      DO 900 I=1,NUMGR
        II=ILC17-1+I
C HERE IWORK(II)=ICNTYP(I).
        IF(IWORK(II))600,900,550
  550   IF(IWORK(II)-1)585,585,570
  570   ITYP2=ITYP2+1
        GO TO 900
  585   ITYP1=ITYP1+1
        GO TO 900
  600   IF(IWORK(II)+1)800,700,700
  700   ITYPM1=ITYPM1+1
        GO TO 900
  800   ITYPM2=ITYPM2+1
  900   CONTINUE
C
C COMPUTE THE ERROR NORMS.  ENORM IS THE PRINCIPAL ERROR NORM.
 1000 ENORM=ERROR(NUMGR+1)
      ENOR2=ERROR(NUMGR+2)
      ENOR3=ERROR(NUMGR+3)
C
C WRITE ITER, ISUCC, IRK, ENCHG, AND THE ERROR NORMS.
 1050 CONTINUE
C1050 WRITE(NWRIT,1100)ITER,ISUCC,IRK,ENCHG,ENORM,ENOR2,ENOR3
C     WRITE(9,1100)ITER,ISUCC,IRK,ENCHG,ENORM,ENOR2,ENOR3
C1100 FORMAT(/8H ITER IS,I5,10H  ISUCC IS,I4,8H  IRK IS,I4,
C    *10H  ENCHG IS,E24.14/9H ENORM IS,E24.14,10H  ENOR2 IS,E24.14/
C    *9H ENOR3 IS,E24.14)
C
C
C THE NEXT SECTION DETERMINES WHETHER WE WILL TERMINATE DUE TO ITERATION
C COUNT, AND IF SO FOR OUTPUT PURPOSES IT MODIFIES ITER (OR TWO OF THE
C ERROR NORMS IF THE FAILURE IS DUE TO INABILITY TO GAIN TYPE -2
C FEASIBILITY).
C
C IF IOPTEN=1 AND WE HAVE DONE AT LEAST ONE ITERATION IN THE MAIN PART
C OF CONMAX, WE WILL GIVE UP IF ABS(ENCHG) HAS BEEN LESS THAN ENCSM FOR
C LIMSM CONSECUTIVE MAIN ITERATIONS (INCLUDING THIS ONE).
      IF(IOPTEN-1)1118,1106,1118
 1106 IF(IPHSE)1118,1108,1118
 1108 IF(ITER)1118,1118,1110
 1110 IF(-ENCHG-ENCSM)1114,1112,1112
 1112 KNTSM=0
      GO TO 1118
 1114 KNTSM=KNTSM+1
      IF(KNTSM-LIMSM)1118,1200,1200
C
 1118 IF(ITER-ITLIM1)1300,1120,1120
C
C HERE ITER = ITLIM1, SO WE RETURN.
 1120 IF(IPHSE)1140,1200,1200
C
C HERE WE HAVE FAILED TO ACHIEVE TYPE -2 FEASIBILITY AND WE SET ITER=-2
C AS A WARNING, PUT ERROR(NUMGR+1) IN ITS PROPER LOCATION, SET
C ERROR(NUMGR+1) = 0.0 SINCE THE PRIMARY CONSTRAINTS WERE NOT COMPUTED,
C AND RETURN.  NOTE THAT WE CANNOT HAVE IPHSE=-1 HERE SINCE THAT WOULD
C IMPLY ITER=0, THUS ITLIM=ITLIM1=0, IN WHICH CASE WE WOULD HAVE
C TERMINATED EARLIER.
 1140 ITER=-2
      ERROR(NUMGR+3)=ERROR(NUMGR+1)
      ERROR(NUMGR+1)=ZERO
C     WRITE(6,1150)
C1150 FORMAT(43H ***WARNING  NONLINEAR STANDARD FEASIBILITY,
C    *16H NOT ACHIEVED***)
      RETURN
C
C FOR OUTPUT PURPOSES REPLACE ITER BY ITER + ITLIM - ITLIM1, THE TRUE
C NUMBER OF ITERATIONS COUNTING INITIALIZATION.  ITLIM - ITLIM1 WILL BE
C THE NUMBER OF ITERATIONS NEEDED TO GAIN TYPE -2 FEASIBILITY.  WORK
C DONE TO GAIN TYPE -1 FEASIBILITY IS NOT COUNTED AS AN ITERATION.
 1200 ITER=ITER+ITLIM-ITLIM1
C
 1205 RETURN
C
C HERE ITER .LT. ITLIM1.  IF IPHSE = 0 OR -2 HERE WE GO INTO THE
C ITERATIVE PHASE OF CONMAX.
 1300 IF(IPHSE+1)1450,1302,1450
C
C
C HERE IPHSE=-1 AND WE CHECK TYPE -1 FEASIBILITY, TRY TO REGAIN IT IF
C WE DONT HAVE IT, CHECK TYPE -2 FEASIBILITY, AND SET UP FOR TYPE -2
C FEASIBILITY ITERATIONS IF WE DONT HAVE IT.  THE STATEMENTS FROM HERE
C DOWN TO THE TRIPLE BLANK LINE WILL BE EXECUTED AT MOST ONCE.
C
C NOTE THAT ENOR2=0.0 IF THERE ARE NO TYPE -1 CONSTRAINTS.
 1302 IF(ENOR2-TOLLIN)1304,1304,1316
C
C HERE WE HAD TYPE -1 FEASIBILITY INITIALLY.
 1304 IF(ENOR3-TOLCON)1444,1444,1430
C
C HERE WE DO NOT HAVE TYPE -1 FEASIBILITY SO WE TRY TO GET IT.
C WE WILL NEED TO TELL DERST TO COMPUTE THE VALUES OF THE LEFT SIDES
C OF THE TYPE -1 CONSTRAINTS WITH THE VARIABLES EQUAL TO ZERO (I.E.
C THE CONSTANT TERMS IN THE CONSTRAINTS), SO WE SET PARWRK TO THE
C ZERO VECTOR TO CARRY THE MESSAGE.
 1316 DO 1324 J=1,NPARM
        JJ=ILC27-1+J
C HERE WORK(JJ) = PARWRK(J).
        WORK(JJ)=ZERO
 1324   CONTINUE
      IF(IOPTTH)1328,1328,1326
C HERE IOPTTH=1 AND WE CALL DERST WITH IPT=-1 TO PUT ALL THE STANDARD
C CONSTRAINT AND DERIVATIVE VALUES IN CONFUN.
C WE SET IPT=-1 TO TELL DERST IT NEED ONLY COMPUTE STANDARD CONSTRAINTS.
 1326 IPT=-1
      CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,WORK(ILC27),IPT,
     *WORK(ILC24),WORK(ILC35),IWORK(ILC22),WORK(ILC08))
C
 1328 M=0
      DO 1350 I=1,NUMGR
        II=ILC17-1+I
C HERE WE CONSIDER ONLY TYPE -1 CONSTRAINTS.  THERE MUST BE AT LEAST
C ONE OF THESE, SINCE OTHERWISE WE WOULD NOT BE HERE ATTEMPTING TO
C GAIN TYPE -1 FEASIBILITY.
C HERE IWORK(II)=ICNTYP(I).
        IF(IWORK(II)+1)1350,1330,1350
 1330   M=M+1
        IF(IOPTTH)1332,1332,1335
C HERE IOPTTH=0 AND WE HAVE NOT YET CALLED DERST TO PUT CONSTRAINT I
C AND ITS DERIVATIVES IN CONFUN, SO WE DO IT NOW.
 1332   IPT=I
        CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,WORK(ILC27),IPT,
     *  WORK(ILC24),WORK(ILC35),IWORK(ILC22),WORK(ILC08))
C COPY THE DERIVATIVES INTO PMAT FOR USE BY WOLFE.
 1335   DO 1340 L=1,NPARM
          L1=ILC29-1+L+(M-1)*NPAR1
          L2=ILC08-1+I+L*NUMGR
C HERE WORK(L1)=PMAT(L,M) AND WORK(L2)=CONFUN(I,L+1).
          WORK(L1)=WORK(L2)
 1340     CONTINUE
C
C NOW THE ITH CONSTRAINT (WHICH IS ALSO THE MTH TYPE -1 CONSTRAINT) HAS
C THE FORM PMAT(1,M)*Z1+...+PMAT(NPARM,M)*ZNPARM + CONFUN(I,1)  .LE.
C 0.0.  WE MAKE THE CHANGE OF VARIABLES ZZ = Z - PARAM TO TRANSLATE THE
C ORIGIN TO PARAM.  THE ITH CONSTRAINT WILL THEN HAVE THE FORM
C PMAT(1,M)*ZZ1+...+PMAT(NPARM,M)*ZZNPARM + (CONFUN(I,1) + PMAT(1,M)*
C PARAM(1)+...+PMAT(NPARM,M)*PARAM(NPARM)) .LE. 0.0.  AFTER WOLFE FINDS
C THE CLOSEST POINT TO THE ORIGIN IN THE POLYHEDRON DEFINED BY THE NEW
C CONSTRAINTS, WE WILL ADD PARAM TO TRANSLATE BACK TO THE POINT WE WANT.
        L1=ILC29-1+NPAR1+(M-1)*NPAR1
        L2=ILC08-1+I
C HERE WORK(L1)=PMAT(NPAR1,1) AND WORK(L2)=CONFUN(I,1).
        WORK(L1)=WORK(L2)
        DO 1345 L=1,NPARM
          L2=ILC29-1+L+(M-1)*NPAR1
C HERE WORK(L1)=PMAT(NPAR1,1) AND WORK(L2)=PMAT(L,M).
          WORK(L1)=WORK(L1)+WORK(L2)*PARAM(L)
 1345     CONTINUE
 1350   CONTINUE
C CALL WOLFE WITH ISTRT=0 TO COMPUTE THE SOLUTION IN THE ZZ COORDINATE
C SYSTEM FROM SCRATCH.
      CALL WOLFE(NPARM,M,WORK(ILC29),0,S,NCOR,IWORK(ILC15),IWORK,LIWRK,
     *WORK,LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),NPARM,
     *NUMGR,WORK(ILC40),WORK(ILC42),WDIST,NMAJ,NMIN,JFLAG)
      IF(JFLAG)1365,1365,1355
C
C HERE WE HAVE FAILED TO ACHIEVE TYPE -1 FEASIBILITY.  WE SET ITER=-1
C AS A WARNING AND RETURN.
 1355 ITER=-1
C     WRITE(NWRIT,1360)
C1360 FORMAT(40H ***WARNING  LINEAR STANDARD FEASIBILITY,
C    *16H NOT ACHIEVED***)
      RETURN
C
C HERE JFLAG .LE. 0 AND WE PUT PARAM+WPT IN PARWRK TO CHECK WHETHER
C THE TYPE -1 CONSTRAINTS ARE NOW FEASIBLE WITHIN TOLLIN.
 1365 DO 1370 J=1,NPARM
        J1=ILC27-1+J
        J2=ILC42-1+J
C HERE WORK(J1)=PARWRK(J) AND WORK(J2)=WPT(J).
        WORK(J1)=PARAM(J)+WORK(J2)
 1370   CONTINUE
C FOR USE IN ERCMP1 WE SET JCNTYP(I)=-1 IF ICNTYP(I)=-1 AND SET
C JCNTYP(I)=0 OTHERWISE.
      DO 1385 I=1,NUMGR
        II=ILC17-1+I
        JJ=ILC21-1+I
C HERE IWORK(II)=ICNTYP(I) AND IWORK(JJ)=JCNTYP(I).
        IF(IWORK(II)+1)1380,1375,1380
 1375   IWORK(JJ)=-1
        GO TO 1385
 1380   IWORK(JJ)=0
 1385   CONTINUE
C CALL ERCMP1 WITH ICNUSE=1.
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *WORK(ILC27),1,IPHSE,IWORK,LIWRK,WORK(ILC08),IWORK(ILC21),
     *IPMAX,ISMAX,WORK(ILC11))
      I1=ILC11-1+(NUMGR+2)
C HERE WORK(I1)=ERR1(NUMGR+2).
      IF(WORK(I1)-TOLLIN)1390,1390,1355
C
C HERE WE HAVE ACHIEVED TYPE -1 FEASIBILITY.  WE REPLACE PARAM WITH
C PARWRK.
 1390 DO 1395 J=1,NPARM
        JJ=ILC27-1+J
C HERE WORK(JJ)=PARWRK(J).
        PARAM(J)=WORK(JJ)
 1395   CONTINUE
      II=ILC11-1+NUMGR+2
C HERE WORK(II)=ERR1(NUMGR+2).
C     WRITE(NWRIT,1397)WORK(II),(PARAM(J),J=1,NPARM)
C1397 FORMAT(48H TYPE -1 FEASIBILITY ACHIEVED.  ERR1(NUMGR+2) IS,
C    *E15.5,10H  PARAM IS/(4E20.12))
C
C IF THERE ARE TYPE -2 CONSTRAINTS, SET JCNTYP AS ICNTYP WITH ALL BUT -2
C VALUES ZEROED OUT AND CALL ERCMP1 WITH ICNUSE=1 TO CHECK TYPE -2
C FEASIBILITY.  WE CANNOT SIMPLY CHECK THE OLD ENOR3 HERE SINCE PARAM HAS
C BEEN CHANGED.  IF THERE ARE NO TYPE -2 CONSTRAINTS WE WILL AUTOMATICALLY
C HAVE TYPE -2 FEASIBILITY.
      IF(ITYPM2)1415,1415,1398
 1398 DO 1410 I=1,NUMGR
        II=ILC17-1+I
        JJ=ILC21-1+I
C HERE IWORK(II)=ICNTYP(I) AND IWORK(JJ)=JCNTYP(I).
        IF(IWORK(II)+1)1400,1405,1405
 1400   IWORK(JJ)=-2
        GO TO 1410
 1405   IWORK(JJ)=0
 1410   CONTINUE
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARAM,1,IPHSE,IWORK,LIWRK,WORK(ILC08),IWORK(ILC21),IPMAX,
     *ISMAX,WORK(ILC11))
      II=ILC11-1+NUMGR+3
C HERE WORK(II)=ERR1(NUMGR+3).
      IF(WORK(II)-TOLCON)1415,1415,1430
C
C HERE WE HAVE BOTH TYPE -1 AND TYPE -2 FEASIBILITY, BUT PARAM WAS
C CHANGED IN GETTING TYPE -1 FEASIBILITY, SO WE CALL ERCMP1
C WITH ICNUSE=0 (ICNUSE=1 WOULD WORK ALSO SINCE ICNTYP HAS NOT BEEN
C CHANGED HERE) TO GET THE NEW ERROR VECTOR.
 1415 CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARAM,0,IPHSE,IWORK,LIWRK,WORK(ILC08),IWORK(ILC17),IPMAX,
     *ISMAX,ERROR)
      GO TO 1444
C
C HERE WE HAVE TYPE -1 FEASIBILITY BUT NOT TYPE -2 FEASIBILITY.  WE SET
C UP FOR THE TYPE -2 FEASIBILITY ITERATIONS, IN WHICH TYPE 1 AND TYPE
C 2 CONSTRAINTS ARE IGNORED AND TYPE -2 CONSTRAINTS ARE TREATED AS
C TYPE 1 CONSTRAINTS, EXCEPT WE WILL SWITCH OVER TO NORMAL ITERATIONS
C ONCE WE CAN FORCE W .LE. TOLCON.  THUS WE SET THE INDICATOR IPHSE TO
C -2, RESET ICNTYP(I) TO 1 IF IT WAS -2, LEAVE IT AT -1 IF IT WAS -1,
C AND SET IT TO 0 OTHERWISE, RESET ITYP2, ITYP1, AND ITYPM2, AND CALL
C ERCMP1 WITH ICNUSE=1 TO PUT THE PROPER VALUES IN ERROR.
 1430 IPHSE=-2
      DO 1439 I=1,NUMGR
        II=ILC17-1+I
C HERE IWORK(II)=ICNTYP(I).
        IF(IWORK(II)+1)1433,1439,1436
 1433   IWORK(II)=1
        GO TO 1439
 1436   IWORK(II)=0
 1439   CONTINUE
C SAVE ITYP2 AND ITYP1.
      ITYP2K=ITYP2
      ITYP1K=ITYP1
      ITYP2=0
      ITYP1=ITYPM2
      ITYPM2=0
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARAM,1,IPHSE,IWORK,LIWRK,WORK(ILC08),IWORK(ILC17),IPMAX,
     *ISMAX,ERROR)
      GO TO 1450
C
C HERE WE HAVE BOTH TYPE -1 AND TYPE -2 FEASIBILITY, AND WE
C SET IPHSE=0 AND GO INTO THE MAIN PART OF CONMAX (UNLESS THERE WERE
C NO TYPE 1 OR TYPE 2 CONSTRAINTS, IN WHICH CASE WE RETURN).
 1444 IPHSE=0
      IF(ITYP1+ITYP2)1205,1205,1450
C
C END OF INITIAL FEASIBILITY CHECKING, TYPE -1 FEASIBILITY WORK, AND
C TYPE -2 SETUP.  THE BLOCK OF STATEMENTS FROM HERE UP TO THE
C PRECEDING DOUBLE BLANK LINE WILL NOT BE EXECUTED AGAIN.
C
C
C
 1450 IF(IRK)1475,1475,1500
C
C HERE IRK IS 0 OR -1 AND WE DO AN SLP STEP.  IF SLPCON CANNOT REDUCE THE
C PRINCIPAL ERROR NORM ENORM = ERROR(NUMGR+1) BY MORE THAN 100.0*B**(-ITT)
C THEN IT WILL LEAVE PARAM AND ERROR UNCHANGED.
 1475 CALL SLPCON(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *TOLCON,RCHIN,IRK,ITYPM1,ITYPM2,IWORK(ILC17),RCHDWN,NUMLIM,ITERSL,
     *PRJSLP,WORK(ILC12),IWORK(ILC20),WORK(ILC44),MACT1,IWORK(ILC14),
     *IWORK(ILC21),IPHSE,ENCHG,IWORK,LIWRK,WORK,LWRK,WORK(ILC26),
     *ISUCC,PARAM,ERROR)
      GO TO 1600
C
C HERE IRK IS 1 OR 2 AND WE DO AN RK STEP.  IF RKCON CANNOT REDUCE THE
C PRINCIPAL ERROR NORM ENORM = ERROR(NUMGR+1) BY MORE THAN 100.0*B**(-ITT)
C THEN IT WILL LEAVE PARAM AND ERROR UNCHANGED.
 1500 CALL RKCON(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *TOLCON,RCHIN,ITER,IRK,ITYP2,ITYP1,ITYPM1,ITYPM2,IWORK(ILC17),
     *PROJCT,RCHDWN,NSTEP,IPHSE,ENCHG,ENC1,WORK(ILC29),WORK(ILC12),
     *IWORK,LIWRK,WORK,LWRK,IWORK(ILC13),WORK(ILC02),WORK(ILC25),
     *WORK(ILC26),WORK(ILC46),WORK(ILC11),WORK(ILC08),ISUCC,PARAM,
     *ERROR)
C
 1600 IF(ISUCC)1700,1700,2100
C HERE THE RK OR SLP STEP REDUCED ERROR(NUMGR+1) BY MORE THAN
C 100.0*B**(-ITT), AND WE INCREMENT ITER.
 1700 ITER=ITER+1
C
C IF EITHER IPHSE=0, OR IPHSE=-2 AND ERROR(NUMGR+1) .GT. TOLCON, WE GO
C ON AS USUAL TO SET UP ANOTHER STEP WITH THE SAME IPHSE.
      IF(IPHSE)1710,1790,1790
 1710 IF(ERROR(NUMGR+1)-TOLCON)1720,1720,1790
C
C HERE IPHSE=-2 AND ERROR(NUMGR+1) .LE. TOLCON, SO WE HAVE JUST ACHIEVED
C TYPE -2 FEASIBILITY.  WE WILL SET IPHSE=0, AND IF THERE ARE ANY
C PRIMARY CONSTRAINTS WE WILL RESET ITER, ITERSL, AND ITLIM1 (SINCE
C ITER=0 AND ITERSL=0 HAVE MEANINGS TO RKCON AND SLPCON RESPECTIVELY),
C RESET RCHIN AND RCHDWN, AND GO BACK TO THE FIRST ERCMP1 CALL TO
C RESTORE ERROR AND ICNTYP (ITYP1, ITYP2, ITYPM1, AND ITYPM2 WILL ALSO
C BE RESTORED).
 1720 IPHSE=0
      IF(ITYP1K+ITYP2K)1205,1205,1730
 1730 ITLIM1=ITLIM-ITER
      ITER=0
      ITERSL=0
      RCHIN=RCHDWN
      RCHDWN=RCHDNK
      GO TO 500
C
 1790 IF(IRK)1800,1900,2000
C
C HERE WE HAD AN SLP SUCCESS AND WE ARE GOING TO TRY RK AGAIN, SO WE SET
C IRK=2 TO WARN RKCON THAT THE SUCCESS CAME FROM SLP.
 1800 IRK=2
C HERE WE HAD AN SLP SUCCESS AND WE INCREMENT ITERSL = THE NUMBER OF SLP
C SUCCESSES SINCE THE LAST SUCCESSFUL RK STEP (IF ANY).  ITERSL IS NEEDED
C IN SUBROUTINE BNDSET (CALLED BY SLPCON).
 1900 ITERSL=ITERSL+1
      GO TO 1000
C
C HERE IRK IS 1 OR 2, SO WE JUST HAD AN RK SUCCESS.  WE RESET IRK AND
C ITERSL.
 2000 IRK=1
      ITERSL=0
      GO TO 1000
C
C HERE RKCON OR SLPCON FAILED TO SIGNIFICANTLY REDUCE THE PRINCIPAL ERROR
C NORM.  IF WE JUST TRIED SLP WE QUIT, AND IF WE JUST TRIED RK WE ATTEMPT
C AN SLP STEP UNLESS IOPTHO = 2, IN WHICH CASE WE QUIT.
 2100 IF(IRK)2300,2300,2150
 2150 IF(IOPTHO-2)2200,2300,2200
 2200 IRK=-1
      GO TO 1050
C
C IF IPHSE=-2 HERE WE WILL SET ITER=-2 AS A WARNING AND CHANGE
C ERROR(NUMGR+1) AND ERROR(NUMGR+3) BEFORE RETURNING.  OTHERWISE WE WILL
C HAVE IPHSE=0 AND WE WILL ADJUST ITER BEFORE RETURNING.
 2300 IF(IPHSE)1140,1200,1200
      END
C     FUNCTION I1MACH(I)
CC
CC THIS IS THE FIRST OF TWO FUNCTION SUBPROGRAMS IN WHICH THE USER SETS
CC MACHINE DEPENDENT CONSTANTS.  IT SETS THE INPUT AND OUTPUT UNIT
CC NUMBERS.
CC
CC I1MACH(1) IS THE INPUT UNIT NUMBER, AND I1MACH(2) IS THE OUTPUT
CC UNIT NUMBER.
C     IF(I-1)1,1,2
C   1 I1MACH=5
C     RETURN
C   2 I1MACH=6
C     RETURN
C     END
C     FUNCTION D1MACH(I)
C
CC***BEGIN PROLOGUE  D1MACH
CC***ROUTINES CALLED  (NONE)
CC***PURPOSE  THIS IS THE SECOND OF TWO FUNCTION SUBPROGRAMS IN
CC            WHICH THE USER MUST SET MACHINE DEPENDENT CONSTANTS.
CC            IT SETS THE PRECISION DEPENDENT CONSTANT
CC
CC                 D1MACH(3) = B**(-ITT)
CC
CC            WHERE B IS THE BASE FOR FLOATING POINT NUMBERS, AND
CC            ITT IS THE NUMBER OF BASE B DIGITS IN THE MANTISSA.
CC***REMARK  TO CONVERT THIS PROGRAM FROM DOUBLE PRECISION TO SINGLE
CC           PRECISION (FOR EXAMPLE), ON MANY MACHINES ONE NEED ONLY
CC           RESET D1MACH(3), PUT A C IN COLUMN 1 OF ALL THE STATEMENTS
CC
CC                IMPLICIT REAL*8 (A-H,O-Z)
CC
CC           AND CONVERT THE DRIVER PROGRAM AND SUBROUTINE FNSET TO
CC           SINGLE PRECISION.
CC
C     IMPLICIT REAL*8 (A-H,O-Z)
CC
C     IF(I-3)100,200,100
CC
C 100 RETURN
CC
C 200 D1MACH=16.0D0**(-14)
C     RETURN
C     END
      FUNCTION ILOC(IARR,NPARM,NUMGR)
C
C THIS FUNCTION SUBPROGRAM RETURNS THE SUBSCRIPT OF THE FIRST ELEMENT OF
C ARRAY IARR RELATIVE TO IWORK (IF THE ARRAY IS INTEGER, I.E. 13 .LE.
C IARR .LE. 23) OR RELATIVE TO WORK (IF THE ARRAY IS FLOATING POINT, I.E.
C 1 .LE. IARR .LE. 12 OR 24 .LE. IARR .LE. 48).
C
      GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,
     *170,180,190,200,210,220,230,240,250,260,270,280,290,300,310,320,
     *330,340,350,360,370,380,390,400,410,420,430,440,450,460,470,
     *480),IARR
C
C   1  AA(NPARM+1,NPARM+1)  (OPPOSITE V, Y; STARTS AT V STARTING POINT)
   10 ILOC=3*NUMGR*NPARM+6*NUMGR+11*NPARM+8
      RETURN
C
C   2  ACTDIF(NUMGR)
   20 ILOC=1
      RETURN
C
C   3  B(NPARM+1)  (OPPOSITE V, Y;  FOLLOWS AA)
   30 ILOC=NPARM**2+3*NUMGR*NPARM+6*NUMGR+13*NPARM+9
      RETURN
C
C   4  BETA(NPARM+1)  (OPPOSITE V, Y;  FOLLOWS B)
   40 ILOC=NPARM**2+3*NUMGR*NPARM+6*NUMGR+14*NPARM+10
      RETURN
C
C   5  BNDKP(NPARM) (FOLLOWS ACTDIF)
   50 ILOC=NUMGR+1
      RETURN
C
C   6  COEF(NUMGR)
   60 ILOC=NUMGR+NPARM+1
      RETURN
C
C   7  COFBND(NPARM)
   70 ILOC=2*NUMGR+NPARM+1
      RETURN
C
C   8  CONFUN(NUMGR,NPARM+1)  (OPPOSITE PMAT1)
   80 ILOC=2*NUMGR+2*NPARM+1
      RETURN
C
C   9  D(NPARM+1)  (OPPOSITE V, Y;  FOLLOWS BETA)
   90 ILOC=NPARM**2+3*NUMGR*NPARM+6*NUMGR+15*NPARM+11
      RETURN
C
C  10  DVEC(NPARM) (FOLLOWS CONFUN)
  100 ILOC=NUMGR*NPARM+3*NUMGR+2*NPARM+1
      RETURN
C
C  11  ERR1(NUMGR+3)
  110 ILOC=NUMGR*NPARM+3*NUMGR+3*NPARM+1
      RETURN
C
C  12  FUNTBL(NUMGR,NPARM+1)
  120 ILOC=NUMGR*NPARM+4*NUMGR+3*NPARM+4
      RETURN
C
C  13  IACT(NUMGR)
  130 ILOC=1
      RETURN
C
C  14  IACT1(NUMGR)
  140 ILOC=NUMGR+1
      RETURN
C
C  15  ICOR(NPARM+1)
  150 ILOC=2*NUMGR+1
      RETURN
C
C  16  ICOR1(NPARM+1)  (DOES NOT APPEAR IN PROGRAM BY NAME)
  160 ILOC=2*NUMGR+NPARM+2
      RETURN
C
C  17  ICNTYP(NUMGR)
  170 ILOC=2*NUMGR+2*NPARM+3
      RETURN
C
C  18  IXRCT(NUMGR+2*NPARM)
  180 ILOC=3*NUMGR+2*NPARM+3
      RETURN
C
C  19  IYCCT(NPARM+1) (OPPOSITE KPIVOT)
  190 ILOC=4*NUMGR+4*NPARM+3
      RETURN
C
C  20  IYRCT(NUMGR+2*NPARM)
  200 ILOC=4*NUMGR+5*NPARM+4
      RETURN
C
C  21  JCNTYP(NUMGR)
  210 ILOC=5*NUMGR+7*NPARM+4
      RETURN
C
C  22  KCNTYP(NUMGR)
  220 ILOC=6*NUMGR+7*NPARM+4
      RETURN
C
C  23  KPIVOT(NPARM+1)  (OPPOSITE IYCCT)
  230 ILOC=4*NUMGR+4*NPARM+3
      RETURN
C
C  24  PARAM1(NPARM) (FOLLOWS FUNTBL)
  240 ILOC=2*NUMGR*NPARM+5*NUMGR+3*NPARM+4
      RETURN
C
C  25  PARPRJ(NPARM)
  250 ILOC=2*NUMGR*NPARM+5*NUMGR+4*NPARM+4
      RETURN
C
C  26  PARSER(NPARM)
  260 ILOC=2*NUMGR*NPARM+5*NUMGR+5*NPARM+4
      RETURN
C
C  27  PARWRK(NPARM)
  270 ILOC=2*NUMGR*NPARM+5*NUMGR+6*NPARM+4
      RETURN
C
C  28  PICOR(NPARM+1,NPARM+1)  (OPPOSITE V, Y;  FOLLOWS D)
  280 ILOC=NPARM**2+3*NUMGR*NPARM+6*NUMGR+16*NPARM+12
      RETURN
C
C  29  PMAT(NPARM+1,NUMGR) (FOLLOWS PARWRK)
  290 ILOC=2*NUMGR*NPARM+5*NUMGR+7*NPARM+4
      RETURN
C
C  30  PMAT1(NPARM+1,NUMGR)  (OPPOSITE CONFUN)
  300 ILOC=2*NUMGR+2*NPARM+1
      RETURN
C
C  31  PTNR(NPARM+1) (FOLLOWS PMAT)
  310 ILOC=3*NUMGR*NPARM+6*NUMGR+7*NPARM+4
      RETURN
C
C  32  PTNRR(NPARM+1)
  320 ILOC=3*NUMGR*NPARM+6*NUMGR+8*NPARM+5
      RETURN
C
C  33  R(NPARM+1)
  330 ILOC=3*NUMGR*NPARM+6*NUMGR+9*NPARM+6
      RETURN
C
C  34  SAVE(NPARM+1)
  340 ILOC=3*NUMGR*NPARM+6*NUMGR+10*NPARM+7
      RETURN
C
C  35  V(NUMGR+2*NPARM+1,NPARM+2)  (WITH Y, OPPOSITE AA, B, BETA, D,
C      PICOR, ZWORK)
  350 ILOC=3*NUMGR*NPARM+6*NUMGR+11*NPARM+8
      RETURN
C
C  36  VDER(NPARM) (FOLLOWS Y)
  360 ILOC=2*NPARM**2+4*NUMGR*NPARM+9*NUMGR+18*NPARM+10
      RETURN
C
C  37  VDERN(NPARM)
  370 ILOC=2*NPARM**2+4*NUMGR*NPARM+9*NUMGR+19*NPARM+10
      RETURN
C
C  38  VDERS(NPARM)
  380 ILOC=2*NPARM**2+4*NUMGR*NPARM+9*NUMGR+20*NPARM+10
      RETURN
C
C  39  VEC(NPARM+1)
  390 ILOC=2*NPARM**2+4*NUMGR*NPARM+9*NUMGR+21*NPARM+10
      RETURN
C
C  40  WCOEF(NUMGR)
  400 ILOC=2*NPARM**2+4*NUMGR*NPARM+9*NUMGR+22*NPARM+11
      RETURN
C
C  41  WCOEF1(NUMGR)  (DOES NOT APPEAR IN THE PROGRAM BY NAME)
  410 ILOC=2*NPARM**2+4*NUMGR*NPARM+10*NUMGR+22*NPARM+11
      RETURN
C
C  42  WPT(NPARM)
  420 ILOC=2*NPARM**2+4*NUMGR*NPARM+11*NUMGR+22*NPARM+11
      RETURN
C
C  43  WVEC(NPARM)
  430 ILOC=2*NPARM**2+4*NUMGR*NPARM+11*NUMGR+23*NPARM+11
      RETURN
C
C  44  X(NPARM+1)
  440 ILOC=2*NPARM**2+4*NUMGR*NPARM+11*NUMGR+24*NPARM+11
      RETURN
C
C  45  XKEEP(NPARM+1)
  450 ILOC=2*NPARM**2+4*NUMGR*NPARM+11*NUMGR+25*NPARM+12
      RETURN
C
C  46  XRK(NPARM+1)
  460 ILOC=2*NPARM**2+4*NUMGR*NPARM+11*NUMGR+26*NPARM+13
      RETURN
C
C  47  Y(NUMGR+2*NPARM)  (WITH V, OPPOSITE AA, B, BETA, D, PICOR,
C      ZWORK;  FOLLOWS V)
  470 ILOC=2*NPARM**2+4*NUMGR*NPARM+8*NUMGR+16*NPARM+10
      RETURN
C
C  48  ZWORK(NPARM)  (OPPOSITE V, Y;  FOLLOWS PICOR)
  480 ILOC=2*NPARM**2+3*NUMGR*NPARM+6*NUMGR+18*NPARM+13
      RETURN
      END
      SUBROUTINE DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,
     *IPT,PARAM1,V,KCNTYP,CONFUN)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PTTBL(IPTB,INDM),PARAM(NPARM),PARAM1(NPARM),
     *V(NUMGR+2*NPARM+1,NPARM+2),KCNTYP(NUMGR),
     *CONFUN(NUMGR,NPARM+1)
C
C THIS SUBROUTINE USES FNSET TO COMPUTE CONFUN(I,1) AND THE PARTIAL
C DERIVATIVES OF THE FUNCTION WHOSE VALUE IS IN CONFUN(I,1) FOR
C CERTAIN VALUE(S) OF I.  NOTE THAT WE DO NOT WANT THE ICNTYP COMPUTED
C BY FNSET TO OVERRIDE THE ICNTYP (OR JCNTYP) CARRIED INTO THIS
C SUBROUTINE IN ICNTYP, SO WE USE KCNTYP WHEN WE CALL FNSET.  (THE
C ICNTYP COMPUTED BY FNSET WAS STORED EARLIER THROUGH A CALL TO ERCMP1
C FROM CONMAX.)
C
C IF THE ONES DIGIT OF IOPTN IS 0, WE CALL FNSET WITH INDFN=1 TO DO THE
C COMPUTATIONS DIRECTLY USING FORMULAS SUPPLIED BY THE USER.
      IOPONE=IOPTN-(IOPTN/10)*10
      IF(IOPONE)100,100,200
  100 CALL FNSET (NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,1,KCNTYP,
     *CONFUN)
      RETURN
C
C HERE THE ONES DIGIT OF IOPTN IS 1, AND WE APPROXIMATE THE PARTIAL
C DERIVATIVES USING CENTERED DIFFERENCE APPROXIMATIONS.
C
  200 IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
C
C SET PRECISION DEPENDENT CONSTANTS.
      SPCMN=D1MACH(3)
      DELT=SQRT(SPCMN)
      DELT2=DELT+DELT
      IF(IOPTTH)300,300,700
C
C HERE IOPONE=1 AND IOPTTH=0, AND WE WORK ONLY WITH CONSTRAINT IPT,
C WHERE IPT WILL BE AN INTEGER BETWEEN 1 AND NUMGR.
C L WILL BE THE INDEX OF THE VARIABLE WITH RESPECT TO WHICH WE ARE
C COMPUTING THE PARTIAL DERIVATIVE.
  300 DO 500 L=1,NPARM
C
C SET PARAM1 EQUAL TO PARAM, ECXEPT WITH ITS LTH COMPONENT INCREASED
C BY DELT.
        DO 400 J=1,NPARM
          PARAM1(J)=PARAM(J)
  400     CONTINUE
        PARAM1(L)=PARAM(L)+DELT
C
C NOW CALL FNSET WITH INDFN=0 TO PLACE THE FUNCTION IN CONSTRAINT
C IPT EVALUATED AT POINT PARAM1 IN CONFUN(IPT,1).
        CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM1,IPT,0,
     *  KCNTYP,CONFUN)
        UP=CONFUN(IPT,1)
C
C SET PARAM1 EQUAL TO PARAM, ECXEPT WITH ITS LTH COMOPONENT DECREASED
C BY DELT, AND CALL FNSET AGAIN.
        PARAM1(L)=PARAM(L)-DELT
        CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM1,IPT,0,
     *  KCNTYP,CONFUN)
C
C NOW WE CAN COMPUTE THE CENTERED-DIFFERENCE APPROXIMATION TO THE PARTIAL
C DERIVATIVE OF THE FUNCTION IN CONSTRAINT IPT WITH RESPECT TO THE LTH
C VARIABLE AT THE POINT PARAM.  THIS BELONGS IN CONFUN(IPT,L+1), AND
C WE COULD PUT IT THERE NOW IF THE USER FOLLOWED DIRECTIONS AND DID NOT
C CHANGE CONFUN(IPT,L+1) (SINCE INDFN=0) IN LATER FNSET CALLS, BUT TO
C BE SAFE WE TEMPORARILY STORE IT IN V(L,1).
C NOTE THAT V IS USED ELSEWHERE IN THE PROGRAM, BUT HERE IT IS JUST A
C WORK ARRAY, WHILE THE WORK ARRAY PARAM1 IS NOT USED ELSEWHERE IN
C THE PROGRAM.
        V(L,1)=(UP-CONFUN(IPT,1))/DELT2
  500   CONTINUE
C
C NOW COMPUTE THE VALUE OF THE FUNCTION AT PARAM, AND THEN PUT THE
C EARLIER-COMPUTED PARTIAL DERIVATIVES INTO CONFUN.
      CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,0,
     *KCNTYP,CONFUN)
      DO 600 L=1,NPARM
        CONFUN(IPT,L+1)=V(L,1)
  600   CONTINUE
      RETURN
C
C HERE IOPONE=1 AND IOPTTH=1, AND EACH TIME FNSET IS CALLED IT WILL
C COMPUTE VALUES FOR THE FUNCTIONS IN THE LEFT SIDES OF ALL CONSTRAINTS
C (EXCEPT THOSE WHERE FNSET SETS ICNTYP(I)=0) IF IPT=0, AND WILL COMPUTE
C VALUES FOR THE FUNCTIONS IN THE LEFT SIDES OF ALL STANDARD (I.E. TYPE
C -1 OR -2) CONSTRAINTS IF IPT=-1.
C WE FIRST SAVE IPT IN CASE THE USER CHANGES IT IN A FNSET CALL;  WE WILL
C RESTORE IT AFTER EACH FNSET CALL.
  700 IPTKP=IPT
      NPAR1=NPARM+1
C
C WE WILL COMPUTE APPROXIMATIONS TO PARTIAL DERIVATIVES FOR THOSE
C CONSTRAINTS WHICH FNSET IS ASKED BY IPT TO COMPUTE.  TO DETERMINE WHICH
C THESE ARE WE ZERO OUT KCNTYP;  AFTER A FNSET CALL, THE DESIRED
C CONSTRAINTS WILL BE THE CONSTRAINTS K WITH KCNTYP(K) .NE. 0 IF IPT=0,
C OR THE CONSTRAINTS K WITH KCNTYP(K) .LT. 0 IF IPT=-1.
      DO 800 K=1,NUMGR
        KCNTYP(K)=0
  800   CONTINUE
C
C NOW FOLLOW BASICALLY THE SAME PROCEDURES AS IN THE IOPTTH=0 CASE DONE
C ABOVE.
      DO 1800 L=1,NPARM
        DO 900 J=1,NPARM
          PARAM1(J)=PARAM(J)
  900     CONTINUE
        PARAM1(L)=PARAM(L)+DELT
        CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM1,IPT,0,
     *  KCNTYP,CONFUN)
        IPT=IPTKP
        DO 1300 K=1,NUMGR
          IF(IPT)1100,1000,1000
 1000     IF(KCNTYP(K))1200,1300,1200
 1100     IF(KCNTYP(K))1200,1300,1300
C
C SAVE THE UPPER NUMBERS IN COLUMN NPARM+1 OF V.
 1200     V(K,NPAR1)=CONFUN(K,1)
 1300     CONTINUE
C
C REVISE PARAM1 AND CALL FNSET AGAIN.
        PARAM1(L)=PARAM(L)-DELT
        CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM1,IPT,0,
     *  KCNTYP,CONFUN)
        IPT=IPTKP
        DO 1700 K=1,NUMGR
          IF(IPT)1500,1400,1400
 1400     IF(KCNTYP(K))1600,1700,1600
 1500     IF(KCNTYP(K))1600,1700,1700
C
C STORE THE APPROXIMATE PARTIAL DERIVATIVES WITH RESPECT TO THE LTH
C VARIABLE IN THE LTH COLUMN OF V.
 1600     V(K,L)=(V(K,NPAR1)-CONFUN(K,1))/DELT2
 1700     CONTINUE
 1800   CONTINUE
C CALL FNSET AGAIN TO COMPUTE THE VALUES OF THE FUNCTIONS AT POINT
C PARAM, AND THEN PUT THE EARLIER-COMPUTED PARTIAL DERIVATIVES INTO
C CONFUN.
      CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,0,
     *KCNTYP,CONFUN)
      DO 2300 K=1,NUMGR
        IF(IPT)2000,1900,1900
 1900   IF(KCNTYP(K))2100,2300,2100
 2000   IF(KCNTYP(K))2100,2300,2300
 2100   DO 2200 L=1,NPARM
          CONFUN(K,L+1)=V(K,L)
 2200     CONTINUE
 2300   CONTINUE
      RETURN
      END
      SUBROUTINE SLPCON(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,
     *INDM,TOLCON,RCHIN,IRK,ITYPM1,ITYPM2,ICNTYP,RCHDWN,NUMLIM,ITERSL,
     *PRJSLP,FUNTBL,IYRCT,X,MACT1,IACT1,JCNTYP,IPHSE,ENCHG,IWORK,
     *LIWRK,WORK,LWRK,PARSER,ISUCC,PARAM,ERROR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),ICNTYP(NUMGR),
     *FUNTBL(NUMGR,NPARM+1),IYRCT(NUMGR+2*NPARM),X(NPARM+1),
     *IACT1(NUMGR),PARAM(NPARM),ERROR(NUMGR+3),JCNTYP(NUMGR),
     *PARSER(NPARM),IWORK(LIWRK),WORK(LWRK)
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      BIG=ONE/SPCMN
      TOL1=TEN*TEN*SPCMN
      TOL2=TEN*SPCMN
      ILC05=ILOC(5,NPARM,NUMGR)
      ILC07=ILOC(7,NPARM,NUMGR)
      ILC08=ILOC(8,NPARM,NUMGR)
      ILC11=ILOC(11,NPARM,NUMGR)
      ILC13=ILOC(13,NPARM,NUMGR)
      ILC18=ILOC(18,NPARM,NUMGR)
      ILC19=ILOC(19,NPARM,NUMGR)
      ILC25=ILOC(25,NPARM,NUMGR)
      ILC35=ILOC(35,NPARM,NUMGR)
      ILC45=ILOC(45,NPARM,NUMGR)
      ILC47=ILOC(47,NPARM,NUMGR)
      NUMIN=0
      ISUCC=0
      ENORM=ERROR(NUMGR+1)
      NPAR1=NPARM+1
      NG3=NUMGR+3
C IF ITERSL=0, SET IYRCT(1)=-1 FOR USE IN SETU1 AND TO TELL SLNPRO NOT
C TO TRY TO USE INFORMATION FROM A PREVIOUS VERTEX.
      IF(ITERSL)50,50,300
   50 IYRCT(1)=-1
C
C CALL BNDSET TO SET (OR RESET) THE COEFFICIENT CHANGE BOUNDS.
  300 CALL BNDSET(NPARM,X,ITERSL,NUMIN,PRJSLP,WORK(ILC07),WORK(ILC45),
     *WORK(ILC05))
C
C CALL SETU1 TO SET UP FOR SLNPRO AND, IF NUMIN=0, TO DETERMINE
C WHICH CONSTRAINTS ARE ACTIVE AND STORE FUNCTION AND GRADIENT VALUES
C FOR THEM IN FUNTBL.
  400 CALL SETU1(IOPTN,NUMGR,NPARM,NUMIN,RCHIN,PTTBL,IPTB,INDM,
     *FUN,IFUN,FUNTBL,WORK(ILC07),PARAM,ICNTYP,RCHDWN,ERROR,MACT1,
     *IACT1,BNDLGT,IYRCT,IPHSE,IWORK,LIWRK,WORK,LWRK,WORK(ILC08),
     *IWORK(ILC13),WORK(ILC35),M)
C
C SET UNIT (FOR USE IN RCHMOD) EQUAL TO THE VALUE OF BNDLGT AFTER
C SETU1 IS CALLED WITH NUMIN=0.
      IF(NUMIN)500,500,1000
  500 UNIT=BNDLGT
C
C CALL SLNPRO TO COMPUTE A SEARCH DIRECTION X.
 1000 CALL SLNPRO(WORK(ILC35),M,NPAR1,IYRCT,WORK(ILC47),
     *IWORK(ILC18),IWORK(ILC19),NPARM,NUMGR,X,INDIC)
C
C IF INDIC .GT. 0 THEN SLNPRO FAILED TO PRODUCE AN X, AND IF WE HAVE
C REACHED THE SLPCON ITERATION LIMIT WE RETURN WITH THE WARNING
C ISUCC=1.
      IF(INDIC)1300,1300,1800
C
C HERE SLNPRO SUCCEEDED AND WE SET PRJSLP=1.0 INITIALLY FOR SEARSL.
 1300 PRJSLP=ONE
C
C WE NOW WISH TO DETERMINE PRJLIM = THE SMALLER OF 1.0/SPCMN AND
C THE LARGEST VALUE OF PRJSLP FOR WHICH THE LINEAR STANDARD CONSTRAINTS
C ARE SATISFIED FOR THE PARAMETER VECTOR PARAM+PRJSLP*X.  THIS
C WILL GIVE AN UPPER BOUND FOR LINE SEARCHING.  NOTE THAT IN
C THEORY WE SHOULD HAVE PRJLIM .GE. 1.0 SINCE THE LINEAR STANDARD
C CONSTRAINTS SHOULD BE SATISFIED FOR PRJSLP=0.0 AND PRJSLP=1.0, BUT
C ROUNDOFF ERROR COULD AFFECT THIS A LITTLE.  IF THERE ARE NO
C LINEAR STANDARD CONSTRAINTS, WE SET PRJLIM=1.0/SPCMN.
 1400 PRJLIM=BIG
C*****INSERT TO MAKE SEARCHING LESS VIOLENT.
C     PRJLIM=TWO
C*****END INSERT
      IF(ITYPM1)1430,1430,1405
 1405 DO 1425 I=1,NUMGR
        IF(ICNTYP(I)+1)1425,1407,1425
C WE WISH TO HAVE SUMMATION (FUNTBL(I,J+1)*(PARAM(J)+PRJSLP*X(J)))
C + C(I) .LE. 0.0 FOR I=1,...,NUMGR, ICNTYP(I) = -1,
C WHERE THE ITH CONSTRAINT APPLIED TO PARAM SAYS
C SUMMATION (FUNTBL(I,J+1)*PARAM(J)) + C(I) .LE. 0.0, SO C(I) IS THE
C CONSTANT TERM ON THE LEFT SIDE OF LINEAR CONSTRANT I.
C THUS FOR I=1,...,NUMGR, ICNTYP(I) = -1, WE WANT PRJLIM*SS .LE. SSS,
C WHERE SS = SUMMATION (FUNTBL(I,J+1)*X(J)) AND SSS = -C(I) -
C SUMMATION (FUNTBL(I,J+1)*PARAM(J)) = -FUNTBL(I,1).
 1407   SS=ZERO
        DO 1410 J=1,NPARM
          SS=SS+FUNTBL(I,J+1)*X(J)
 1410     CONTINUE
C IF SS .LT. 10.0*SPCMN THIS CONSTRAINT WILL NOT PUT A SIGNIFICANT
C RESTRICTION ON PRJSLP.
        IF(SS-TOL2)1425,1415,1415
C HERE SS .GE. 10.0*SPCMN AND WE COMPARE SSS/SS AGIANST PRJLIM.
 1415   QUOTS=-FUNTBL(I,1)/SS
        IF(PRJLIM-QUOTS)1425,1425,1420
 1420   PRJLIM=QUOTS
 1425   CONTINUE
C DO NOT ALLOW A PRJSLP SMALLER THAN TOL1.
 1430 IF(PRJSLP-TOL1)1440,1470,1470
 1440 PRJSLP=TOL1
C CALL SEARSL TO DO A LINE SEARCH IN DIRECTION X.
 1470 CALL SEARSL(IOPTN,NUMGR,NPARM,PRJLIM,TOL1,X,FUN,IFUN,PTTBL,
     *IPTB,INDM,PARAM,ERROR,RCHDWN,MACT1,IACT1,IPHSE,UNIT,
     *TOLCON,RCHIN,ITYPM1,ITYPM2,IWORK,LIWRK,WORK,LWRK,WORK(ILC11),
     *WORK(ILC25),PRJSLP,EMIN,EMIN1,PARSER,NSRCH)
C
C COMPUTE THE ERROR NORM CHANGE ENCHG.
      ENCHG=EMIN-ENORM
C
C IF WE HAVE AN IMPROVEMENT IN THE ERROR NORM ENORM OF MORE THAN TOL1
C WE UPDATE PARAM AND ERROR AND RETURN WITH ISUCC=0, INDICATING SUCCESS.
C OTHERWISE WE CHECK TO SEE IF WE HAVE REACHED THE SLPCON ITERATION
C LIMIT, AND IF SO WE RETURN WITH ISUCC=1, INDICATING FAILURE.
      IF(ENCHG+TOL1)1600,1800,1800
C
C HERE WE HAD AN IMPROVEMENT IN THE ERROR NORM ENORM OF MORE THAN TOL1.
 1600 DO 1700 J=1,NPARM
        PARAM(J)=PARSER(J)
 1700   CONTINUE
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARAM,1,IPHSE,IWORK,LIWRK,WORK(ILC08),ICNTYP,IPMAX,
     *ISMAX,ERROR)
      RETURN
C
C HERE WE DID NOT OBTAIN AN IMPROVED ERROR NORM SO WE RETURN WITH THE
C WARNING ISUCC=1 IF WE HAVE DONE NUMLIN ITERATIONS IN SLPCON.
 1800 IF(NUMIN-NUMLIM)2000,1900,1900
 1900 ISUCC=1
      RETURN
C
C HERE WE DID NOT OBTAIN AN IMPROVED ERROR NORM BUT WE HAVE NOT YET DONE
C NUMLIM ITERATIONS IN SLPCON SO WE INCREMENT NUMIN, SET IYRCT(1)=-1 TO
C TELL SLNPRO NOT TO TRY TO USE INFORMATION FROM THE PREVIOUS FAILED
C VERTEX, AND GO BACK TO CALL BNDSET AND TRY ANOTHER ITERATION WITH
C A DIFFERENT TRUST REGION.
 2000 NUMIN=NUMIN+1
      IYRCT(1)=-1
      GO TO 300
      END
      SUBROUTINE BNDSET(NPARM,X,ITERSL,NUMIN,PRJSLP,COFBND,XKEEP,
     *BNDKP)
C
C THIS SUBROUTINE SETS THE BOUNDS ON THE COEFFICIENT CHANGES IN
C SLNPRO.
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION X(NPARM+1),COFBND(NPARM),XKEEP(NPARM+1),BNDKP(NPARM)
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR BNDSET.
      ONE=1.0D0
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
C     NWRIT=I1MACH(2)
      SPCMN=D1MACH(3)
C
C SET INITIAL PARAMETERS.  FACT1, FACT3A, FACT3B, CHLM1, AND CHLM2
C SHOULD BE BETWEEN 0.0 AND 1.0, WHILE FACT2 SHOULD BE .GT. 1.0.
      FACT1=(ONE+TWO)/FOUR
      FACT2=TWO
      FACT3A=ONE/TEN
      FACT3B=ONE/(TEN*TEN)
      FACT4=TWO/TEN
      CHLM1=ONE/TEN
      CHLM2=(FOUR+FOUR)/TEN
      TSTPRJ=ONE/TWO-ONE/(TEN*TEN*TEN)
      EPSIL=TEN*TEN*SPCMN
      EPSIL1=(ONE+ONE/(TEN*TEN*TEN))*EPSIL
C BND IS THE INITIAL BOUND ON ALL COEFFICIENT CHANGES.
      BND=TWO/(TEN*TEN)
C END OF SETTING MACHINE AND PRECISION DEPENDENT CONSTANTS FOR BNDSET.
C
      IF(NUMIN-1)100,2000,2100
  100 IF(ITERSL-1)200,400,600
C
C HERE NUMIN=0 AND ITERSL=0, SO WE ARE IN THE FIRST BNDSET CALL SINCE THE
C LAST RK SUCCESS (IF ANY), SO WE SET INITIAL BOUNDS.
  200 DO 300 J=1,NPARM
        COFBND(J)=BND
  300   CONTINUE
      RETURN
C
C HERE NUMIN=0 AND ITERSL=1, SO THE LAST BNDSET CALL RESULTED IN
C THE FIRST SUCCESSFUL PRINCIPAL ERROR NORM IMPROVEMENT,
C AND SO WE SAVE COFBND IN BNDKP AND X IN XKEEP.  WE WILL NOT
C CHANGE COFBND HERE.
  400 DO 500 J=1,NPARM
        XKEEP(J)=X(J)
        BNDKP(J)=COFBND(J)
  500   CONTINUE
      RETURN
C
C HERE NUMIN=0 AND ITERSL .GE. 2, SO WE HAVE HAD AT LEAST 2 SUCCESSES,
C WITH THE COEFFICIENTS AND BOUNDS FOR THE LAST ONE IN X AND
C COFBND RESPECTIVELY, AND THE COEFFICIENTS AND BOUNDS FOR THE
C PREVIOUS ONE IN XKEEP AND BNDKP RESPECTIVELY.  WE WILL FORM A
C NEW COFBND, AND SHIFT THE OLD COFBND INTO BNDKP AND X INTO XKEEP.
  600 DO 1900 J=1,NPARM
C SAVE THE OLD COFBND(J) IN BSAVE.
        BSAVE=COFBND(J)
C IF AT BOTH THE LAST AND PREVIOUS SUCCESSFUL ITERATION THE CHANGES
C IN A COEFFICIENT RELATIVE TO ITS BOUND WERE .GE. CHLM2 IN ABSOLUTE
C VALUE AND IN THE SAME DIRECTION, WE LOOSEN THE BOUND BY A FACTOR
C OF FACT2.  IF THE RELATIVE CHANGES WERE .GE. CHLM1 IN ABSOLUTE
C VALUE AND IN OPPOSITE DIRECTIONS, WE TIGHTEN THE BOUND BY A FACTOR
C OF FACT1 BECAUSE OF SUSPECTED OSCILLATION.  WE ALSO TIGHTEN THE
C BOUND IF BOTH RELATIVE CHANGES WERE LESS THAN CHLM1 IN ABSOLUTE
C VALUE IN ORDER TO PREVENT A LONG SEQUENCE OF OSCILLATIONS OF THE
C SAME SMALL ORDER.  OTHERWISE WE LEAVE THE BOUND ALONE.
C THE NEXT FOUR IF STATEMENTS CHECK TO SEE IF THE BOUND SHOULD BE
C LOOSENED.
        IF(X(J)-CHLM2*COFBND(J))800,700,700
  700   IF(XKEEP(J)-CHLM2*BNDKP(J))1100,1000,1000
  800   IF(X(J)+CHLM2*COFBND(J))900,900,1100
  900   IF(XKEEP(J)+CHLM2*BNDKP(J))1000,1000,1100
C LOOSEN THE BOUND.
 1000   COFBND(J)=FACT2*COFBND(J)
        GO TO 1800
C
C HERE THE BOUND SHOULD NOT BE LOOSENED.  THE NEXT FIVE IF
C STATEMTENTS CHECK TO SEE IF IT SHOULD BE TIGHTENED.
 1100   IF(X(J)-CHLM1*COFBND(J))1300,1200,1200
 1200   IF(XKEEP(J)+CHLM1*BNDKP(J))1600,1600,1800
 1300   IF(X(J)+CHLM1*COFBND(J))1400,1400,1500
 1400   IF(XKEEP(J)-CHLM1*BNDKP(J))1800,1600,1600
C HERE WE HAVE ABS(X(J)) .LT. CHLM1*COFBND(J).
 1500   IF(ABS(XKEEP(J))-CHLM1*BNDKP(J))1600,1800,1800
C TIGHTEN THE BOUND.
 1600   COFBND(J)=FACT1*COFBND(J)
C DO NOT ALLOW THE BOUND TO DROP BELOW EPSIL.
        IF(COFBND(J)-EPSIL)1700,1800,1800
 1700   COFBND(J)=EPSIL
C
C SAVE X(J) AND THE OLD COFBND(J).
 1800   BNDKP(J)=BSAVE
        XKEEP(J)=X(J)
 1900   CONTINUE
C
C IF THE LAST PROJECTION FACTOR IS SMALLER THAN .499, WE TIGHTEN THE
C BOUNDS BY A FACTOR OF 0.2, WITH THE RESTRICTION THAT WE DO NOT
C ALLOW THE BOUNDS TO DROP BELOW EPSIL.
      IF(PRJSLP-TSTPRJ)1920,1980,1980
 1920 DO 1960 J=1,NPARM
        COFBND(J)=FACT4*COFBND(J)
        IF(COFBND(J)-EPSIL)1940,1960,1960
 1940   COFBND(J)=EPSIL
 1960   CONTINUE
 1980 RETURN
C
C HERE NUMIN=1 SO THE LAST BNDSET CALL RESULTED IN FAILURE TO
C IMPROVE THE PRINCIPAL ERROR NORM, AND WE SET FACT3=
C FACT3A AND TIGHTEN THE BOUNDS.
 2000 FACT3=FACT3A
      GO TO 2200
C
C HERE NUMIN .GT. 1 SO THERE HAVE BEEN AT LEAST 2 SUCCESSIVE
C FAILURES, AND WE SET FACT3=FACT3B AND TIGHTEN THE BOUNDS.
 2100 FACT3=FACT3B
C
C TIGHTEN THE BOUNDS BY A FACTOR OF FACT3.
 2200 ITIGHT=1
      DO 2700 J=1,NPARM
        BSAVE=COFBND(J)
        COFBND(J)=FACT3*BSAVE
C WE DO NOT ALLOW A BOUND TO DROP BELOW EPSIL.
        IF(COFBND(J)-EPSIL)2300,2600,2600
C IF THE BOUND WAS ALREADY (ESSENTIALLY) AT EPSIL, KEEP TRACK OF
C THIS BY NOT SETTING ITIGHT=0.
 2300   IF(BSAVE-EPSIL1)2500,2500,2400
 2400   ITIGHT=0
 2500   COFBND(J)=EPSIL
        GO TO 2700
 2600   ITIGHT=0
 2700   CONTINUE
C IF ALL THE BOUNDS WERE ALREADY (ESSENTIALLY) AT EPSIL, WE TRY
C RESETTING THE BOUNDS TO THEIR ORIGINAL VALUES.
      IF(ITIGHT)1980,1980,2800
 2800 CONTINUE
C2800 WRITE(NWRIT,2900)
C2900 FORMAT(/52H *****RESETTING BOUNDS TO THEIR ORIGINAL VALUES*****)
      GO TO 200
      END
      SUBROUTINE SETU1(IOPTN,NUMGR,NPARM,NUMIN,RCHIN,PTTBL,IPTB,
     *INDM,FUN,IFUN,FUNTBL,COFBND,PARAM,ICNTYP,RCHDWN,ERROR,MACT1,
     *IACT1,BNDLGT,IYRCT,IPHSE,IWORK,LIWRK,WORK,LWRK,CONFUN,IACT,V,M)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PTTBL(IPTB,INDM),FUN(IFUN),FUNTBL(NUMGR,NPARM+1),
     *COFBND(NPARM),PARAM(NPARM),ERROR(NUMGR+3),
     *V(NUMGR+2*NPARM+1,NPARM+2),IACT(NUMGR),IACT1(NUMGR),
     *IYRCT(NUMGR+2*NPARM),ICNTYP(NUMGR),CONFUN(NUMGR,NPARM+1),
     *IWORK(LIWRK),WORK(LWRK)
C
C THIS SUBROUTINE SETS UP V FOR SLNPRO TO SOLVE A MODIFIED LINEARIZED
C (ABOUT THE OLD PARAMETERS IN PARAM) VERSION OF OUR PROBLEM.
C
C SET MACHINE AND PRECISION CONSTANTS FOR SETU1.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
C END OF SETTING MACHINE AND PRECISION DEPENDENT CONSTANTS FOR SETU1.
C
      ILC22=ILOC(22,NPARM,NUMGR)
      ILC24=ILOC(24,NPARM,NUMGR)
      NPAR1=NPARM+1
      NPAR2=NPARM+2
      IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
C
C THE LINEARIZED PROBLEM REPLACES THE APPROXIMATING FUNCTION BY ITS
C FIRST ORDER TAYLOR SERIES, SO FUN(I)-(APPROXIMATING FUNCTION)(I) IS
C REPLACED BY ERROR(I)-(SUMMATION OF COEFFICIENT CHANGES TIMES PARTIAL
C DERIVATIVES OF THE APPROXIMATING FUNCTION WITH RESPECT TO THOSE
C COEFFICIENTS) IF ICNTYP(I)=2, AND IF ICNTYP(I)=1 WE REPLACE THE LEFT
C SIDE OF CONSTRAINT I BY ERROR(I)+(SUMMATION OF COEFFICIENT CHANGES TIMES
C PARTIAL DERIVATIVES OF THE LEFT SIDE OF CONSTRAINT I).
C V AND M ARE THE OUTPUT QUANTITIES.  M WILL KEEP TRACK OF THE NUMBER
C OF CONSTRAINTS IN THE LP PROBLEM TO BE SOLVED BY SLNPRO.
      M=0
      ENORM=ERROR(NUMGR+1)
      STFUDG=ONE/TEN
C
C COMPUTE THE LENGTH OF THE LONGEST X VECTOR SATISFYING THE COEFFICIENT
C CHANGE BOUNDS.
      SUM=ZERO
      DO 20 J=1,NPARM
        SUM=SUM+(COFBND(J))**2
   20   CONTINUE
      BNDLGT=SQRT(SUM)
      BNDFUD=STFUDG*BNDLGT
C
C WE WILL SAY A PRIMARY CONSTRAINT IS ACTIVE IF ERROR(I) (OR ABS(ERROR(I
C IF ICNTYP(I)=2) .GE. ENORM-RCHDWN*BNDLGT.
      ACTLIM=ENORM-RCHDWN*BNDLGT
C
C WE WILL SAY A TYPE -2 CONSTRAINT IS ACTIVE IF ERROR(I) .GE. -RCHIND.
      RCHIND=RCHIN*BNDLGT
C
      IF(NUMIN)80,80,40
C HERE NUMIN IS NOT 0, AND WE WILL KEEP THE OLD ACTIVE CONSTRAINT SET
C AND FOREGO RECOMPUTING FUNCTION VALUES AND GRADIENTS.
   40 MACT=MACT1
      M=MACT
      DO 60 L=1,MACT
        IACT(L)=IACT1(L)
   60   CONTINUE
      GO TO 440
C
C HERE NUMIN=0, SO WE WILL FIRST COMPUTE A NEW SET OF ACTIVE INDICES,
C THEN PUT THE FUNCTION VALUES AND GRADIENTS FOR THESE INDICES IN
C FUNTBL, WHERE THEY WILL REMAIN THROUGHOUT THIS CALL TO SLPCON.
   80 DO 240 I=1,NUMGR
        IF(ICNTYP(I))220,240,100
  100   IF(ICNTYP(I)-1)120,120,160
C
C HERE ICNTYP(I)=1 AND WE WILL DECLARE THE CONSTRAINT TO BE +ACTIVE IF AND
C ONLY IF ERROR(I) .GE. ACTLIM.
  120   IF(ERROR(I)-ACTLIM)240,140,140
C
C DECLARE CONSTRAINT I TO BE (+)ACTIVE.
  140   M=M+1
        IACT(M)=I
        GO TO 240
C
C HERE ICNTYP(I)=2 AND WE WILL DECLARE THE CONSTRAINT TO BE +ACTIVE IF AND
C ONLY IF ERROR(I) .GE. ACTLIM OR -ACTIVE IF AND ONLY IF ERROR(I)  .LE.
C -ACTLIM.
  160   IF(ERROR(I)-ACTLIM)180,140,140
  180   IF(ERROR(I)+ACTLIM)200,200,240
C
C DECLARE CONSTRAINT I TO BE -ACTIVE.
  200   M=M+1
        IACT(M)=-I
        GO TO 240
C
C HERE ICNTYP(I) .LT. 0 AND WE WILL DECLARE THE CONSTRAINT TO BE ACTIVE IF
C AND ONLY IF ICNTYP(I)=-1, OR ICNTYP(I)=-2 AND ERROR(I) .GE. -RCHIND.
  220   IF(ICNTYP(I)+1)230,140,140
  230   IF(ERROR(I)+RCHIND)240,140,140
  240   CONTINUE
      MACT=M
C
C NOW PUT ACTIVE VALUES AND GRADIENTS IN FUNTBL.
      IF(IOPTTH)260,260,380
C HERE IOPTTH=0 AND WE CALL DERST FOR EACH ACTIVE CONSTRAINT.
  260 DO 360 L=1,MACT
        I=IABS(IACT(L))
        IPT=I
C CALL DERST TO COMPUTE BOTH FUNCTION AND GRADIENT VALUES.
        CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *  WORK(ILC24),V,IWORK(ILC22),CONFUN)
C COPY THE VALUES FOR CONSTRAINT I INTO FUNTBL.
        DO 340 J=1,NPAR1
          FUNTBL(I,J)=CONFUN(I,J)
  340     CONTINUE
  360   CONTINUE
      GO TO 440
C
C HERE IOPTTH=1 AND ONLY ONE DERST CALL IS NEEDED.
C IF IPHSE .LT. 0 OR NO ICNTYP(L) IS POSITIVE, SET IPT=-1 TO TELL DERST
C TO COMPUTE STANDARD CONSTRAINTS ONLY, WHILE OTHERWISE SET IPT=0 TO
C TELL DERST TO COMPUTE ALL CONSTRAINTS.
  380 IF(IPHSE)389,383,383
  383 DO 386 L=1,NUMGR
        IF(ICNTYP(L))386,386,392
  386   CONTINUE
  389 IPT=-1
      GO TO 395
  392 IPT=0
  395 CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *WORK(ILC24),V,IWORK(ILC22),CONFUN)
C COPY THE ACTIVE FUNCTION AND GRADIENT VALUES INTO FUNTBL.
      DO 420 L=1,MACT
        I=IABS(IACT(L))
        DO 400 J=1,NPAR1
          FUNTBL(I,J)=CONFUN(I,J)
  400     CONTINUE
  420   CONTINUE
C
C NOW SET UP THE ACTIVE CONSTRAINTS IN V FOR SLNPRO.
  440 DO 680 L=1,MACT
        I=IABS(IACT(L))
        IF(ICNTYP(I))610,680,460
  460   IF(ICNTYP(I)-1)480,480,520
C
C HERE ICNTYP(I)=1 AND WE SET UP A CONSTRAINT OF THE FORM
C GRADIENT.CHANGE - W .LE. -CONSTRAINT VALUE.
  480   DO 500 J=1,NPARM
          V(L,J)=FUNTBL(I,J+1)
  500     CONTINUE
        V(L,NPAR1)=-ONE
        V(L,NPAR2)=-ERROR(I)
        GO TO 680
  520   IF(IACT(L))580,580,540
C
C HERE ICNTYP(I)=2 AND IACT(L) .GT. 0, AND WE SET UP A CONSTRAINT OF THE
C FORM -GRADIENT.CHANGE - W .LE. -(FUN - CONSTRAINT VALUE).
  540   DO 560 J=1,NPARM
          V(L,J)=-FUNTBL(I,J+1)
  560     CONTINUE
        V(L,NPAR1)=-ONE
        V(L,NPAR2)=-ERROR(I)
        GO TO 680
C
C HERE ICNTYP(I)=2 AND IACT(L) .LT. 0, AND WE SET UP A CONSTRAINT OF THE
C FORM GRADIENT.CHANGE - W .LE. FUN - CONSTRAINT VALUE.
  580   DO 600 J=1,NPARM
          V(L,J)=FUNTBL(I,J+1)
  600     CONTINUE
        V(L,NPAR1)=-ONE
        V(L,NPAR2)=ERROR(I)
        GO TO 680
C
  610   IF(ICNTYP(I)+1)630,620,620
C
C HERE ICNTYP(I)=-1 AND WE SET UP A CONSTRAINT OF THE FORM
C GRADIENT.CHANGE .LE. -CONSTRAINT VALUE.
  620   DO 625 J=1,NPARM
          V(L,J)=FUNTBL(I,J+1)
  625     CONTINUE
        V(L,NPAR1)=ZERO
        V(L,NPAR2)=-ERROR(I)
        GO TO 680
C
C HERE ICNTYP(I)=-2 AND WE FIRST COMPUTE THE LENGTH OF THE GRADIENT.
  630   SUM=ZERO
        DO 640 J=1,NPARM
          SUM=SUM+(FUNTBL(I,J+1))**2
  640     CONTINUE
        GRDLGT=SQRT(SUM)
C NOW SET UP A CONSTRAINT OF THE FORM GRADIENT.CHANGE  .LE.
C -MIN(1.0,CONSTRAINT VALUE)*BNDFUD*GRDLGT, SO IF GRDLGT .GT. 0.0 WE
C HAVE (-GRADIENT/GRDLGT).(CHANGE/BNDLGT) .GE. STFUDG*MIN(1.0,
C CONSTRAINT VALUE).
        DO 660 J=1,NPARM
          V(L,J)=FUNTBL(I,J+1)
  660     CONTINUE
        V(L,NPAR1)=ZERO
        RT=ERROR(I)
        IF(RT-ONE)675,675,665
  665   RT=ONE
  675   V(L,NPAR2)=-RT*BNDFUD*GRDLGT
  680   CONTINUE
C
C SET THE CONSTRAINTS OF THE FORM -X(J) .LE. COFBND(J) AND
C X(J) .LE. COFBND(J).
      DO 800 J=1,NPARM
        M=M+2
        MM1=M-1
        DO 700 K=1,NPAR1
          V(MM1,K)=ZERO
          V(M,K)=ZERO
  700     CONTINUE
        V(MM1,J)=-ONE
        V(M,J)=ONE
        V(MM1,NPAR2)=COFBND(J)
        V(M,NPAR2)=COFBND(J)
  800   CONTINUE
C
C NOW SET THE BOTTOM ROW.  TO MINIMIZE W = X(NPARM+1) WE MAXIMIZE -W.
      MP1=M+1
      DO 900 J=1,NPAR2
        V(MP1,J)=ZERO
  900   CONTINUE
      V(MP1,NPAR1)=ONE
C
C THIS SECTION ADJUSTS IYRCT TO EITHER TELL SLNPRO TO DO THE INITIAL
C EXCHANGES STRICTLY ACCORDING TO A PIVOTING STRATEGY (BY SETTING
C IYRCT(1)=-1) OR TO SPECIFY AN INITIAL VERTEX FOR SLNPRO, NAMELY THE
C VERTEX CORRESPONDING TO THE LAST LINEAR PROGRAMMING SOLUTION.
C IF IYRCT(1) IS -1 ALREADY WE DO NOT ATTEMPT TO SPECIFY A VERTEX, BUT
C WE STORE MACT IN MACT1 AND IACT IN IACT1 FOR POSSIBLE LATER USE.
      IF(IYRCT(1))1700,1100,1100
C HERE IYRCT(1) .NE. -1, AND WE CONSIDER THE PRESENT ENTRIES IN IYRCT
C ONE BY ONE.
 1100 DO 1600 J=1,NPAR1
        JJ=IYRCT(J)
        IF(JJ-MACT1)1200,1200,1500
C HERE ENTRY J OF IYRCT CORRESPONDS TO A FORMER ACTIVE CONSTRAINT AT
C SOME POINT IABS(KK), WHERE THE SIGN OF KK WILL INDICATE WHETHER THE
C CONSTRAINT WAS +ACTIVE OR -ACTIVE.
 1200   KK=IACT1(JJ)
C WE NOW CHECK TO SEE IF THIS FORMER ACTIVE CONSTRAINT IS STILL
C ACTIVE WITH THE SAME SIGN.  IF SO, WE RESET IYRCT(J) TO THE PRESENT
C NUMBER OF THIS CONSTRAINT, AND IF NOT (WHICH WILL OCCUR IFF THE K
C LOOP BELOW IS COMPLETED), WE WILL NOT TRY TO DETERMINE A VERTEX, SO
C WE WILL SET IYRCT(1)=-1 AND LEAVE THE J LOOP.
        DO 1400 K=1,MACT
          IF(KK-IACT(K))1400,1300,1400
 1300     IYRCT(J)=K
          GO TO 1600
 1400     CONTINUE
        IYRCT(1)=-1
        GO TO 1700
C HERE ENTRY J OF IYRCT CORRESPONDS TO A CONSTRAINT BEYOND THE ACTIVE
C POINT CONSTRAINTS, AND WE ADJUST IYRCT(J) BY THE DIFFERENCE OF THE
C PRESENT AND FORMER NUMBER OF ACTIVE CONSTRAINTS.
 1500   IYRCT(J)=IYRCT(J)+MACT-MACT1
 1600   CONTINUE
C WE HAVE NOW FILLED IN IYRCT(1),...,IYRCT(NPARM+1) WITH DISTINCT
C POSITIVE INTEGERS BETWEEN 1 AND M, AND WE FILL IN THE REST OF IYRCT
C SO THAT IYRCT WILL CONTAIN A PERMUTATION OF 1,...,M.  TO BE CONSISTENT
C WITH SLNPRO WE PUT IYRCT(NPARM+2),...,IYRCT(M) IN DECREASING ORDER.
      L=NPAR1
      DO 1660 I=1,M
        II=M-I+1
C SKIP II IF IT IS ALREADY IN IYRCT.
        DO 1640 J=1,NPAR1
          IF(II-IYRCT(J))1640,1660,1640
 1640     CONTINUE
        L=L+1
        IYRCT(L)=II
 1660   CONTINUE
C
C SAVE MACT IN MACT1 AND IACT IN IACT1 AND RETURN.
 1700 MACT1=MACT
      DO 1800 J=1,MACT
        IACT1(J)=IACT(J)
 1800   CONTINUE
      RETURN
      END
      SUBROUTINE SLNPRO(V,M,N,IYRCT,Y,IXRCT,IYCCT,NPARM,NUMGR,X,
     *INDIC)
C***BEGIN PROLOGUE  SLNPRO
C***ROUTINES CALLED  SJELIM
C***PURPOSE  THIS SUBROUTINE SOLVES THE LINEAR PROGRAMMING PROBLEM
C              MAXIMIZE Z = -V(M+1,1)*X(1)-...-V(M+1,N)*X(N)
C              WHERE X(1),...,X(N) ARE FREE VARIABLES, SUBJECT TO
C              V(I,1)*X(1)+...+V(I,N)*X(N) .LE. V(I,N+1), FOR I=1,..,M,
C              WHERE M .GE. N.
C            (INFORMATION CONCERNING TOLERANCES AND BASIC VARIABLES
C            IS ALSO TRANSMITTED USING M, N, AND IYRCT.)
C***REFERENCES  AVDEYEVA, L. I. AND ZUKHOVITSKIY, S. I.,
C                 LINEAR AND CONVEX PROGRAMMING,
C                 SAUNDERS, PHILADELPHIA, 1966.
C***END PROLOGUE  SLNPRO
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION V(NUMGR+2*NPARM+1,NPARM+2),IYRCT(NUMGR+2*NPARM),
     *X(NPARM+1),Y(NUMGR+2*NPARM),IXRCT(NUMGR+2*NPARM),IYCCT(NPARM+1)
C
C GIVEN INTEGERS M AND N (WITH M .GE. N) AND A MATRIX V,
C THIS SUBROUTINE SOLVES THE LINEAR PROGRAMMING PROBLEM
C    MAXIMIZE Z=-V(M+1,1)X(1)-...-V(M+1,N)X(N)+V(M+1,N+1)
C SUBJECT TO THE CONSTRAINTS
C    V(I,1)X(1)+...+V(I,N)X(N) .LE. V(I,N+1), I=1,...,M
C USING ESSENTIALLY THE METHOD IN THE BOOK BY AVDEYEVA AND
C ZUKHOVITSKIY.  Y(I)=-V(I,1)X(1)-...-V(I,N)X(N)+V(I,N+1),
C I=1,...,M ARE SLACK VARIABLES.  THE METHOD HAS 4 PHASES.
C
C FIRST, XS ARE EXCHANGED FOR YS TO GET A PROBLEM
C INVOLVING ONLY NONNEGATIVE VARIABLES, THE YS BEING
C SELECTED IN THE ORDER DETERMINED BY IYRCT AND A PIVOTING
C STRATEGY.  AT THE BEGINNING OF THIS ROUTINE WE MUST HAVE
C IYRCT(1) NONPOSITIVE, OR IYRCT MUST CONTAIN SOME
C PERMUTATION OF THE INTEGERS 1,...,M (SEE BELOW).
C SECOND, THE SLACK CONSTANTS OF THE DUAL PROBLEM ARE MADE
C (SIGNIFICANTLY) NONNEGATIVE.
C THIRD, THE COST COEFFICIENTS OF THE DUAL PROBLEM ARE MADE
C (SIGNIFICANTLY) NONNEGATIVE.
C FINALLY, THE SOLUTION VECTOR IS COMPUTED.
C
C THE VARIABLE INDIC WILL BE GIVEN VALUE
C 0, IF A SOLUTION WAS FOUND NORMALLY
C 1, IF THERE WAS TROUBLE IN PHASE 1
C 2, IF THERE WAS TROUBLE IN PHASE 2 (EITHER ROUND OFF
C   ERROR, OR THE ORIGINAL PROBLEM WAS INCONSISTENT OR
C   UNBOUNDED)
C 3, IF THERE WAS TROUBLE IN PHASE 3 (EITHER ROUND OFF
C   ERROR, OR THE ORIGINAL CONSTRAINTS WERE INCONSISTENT)
C 4, IF LIMJOR MODIFIED JORDAN ELIMINATIONS WERE USED IN
C   PHASES 2 AND 3
C -1, IF A SOLUTION WAS FOUND BUT IN ORDER TO OVERCOME
C   TROUBLE IN PHASE 2 OR 3 IT WAS NECESSARY TO TEMPORARILY
C   RELAX THE RESTRICTION ON DIVISION BY NUMBERS WITH SMALL
C   ABSOLUTE VALUE.  THUS THERE IS AN INCREASED CHANCE OF
C   SERIOUS ROUNDOFF ERROR IN THE RESULTS.
C -2, IF A SOLUTION WAS FOUND NORMALLY, EXCEPT THAT
C   THE PARAMETERS REA AND REA1 WERE INCREASED BY A SIGNAL
C   FROM THE CALLING PROGRAM (NAMELY, M=-M).  THE INCREASED
C   TOLERANCES MAY HAVE ALLOWED MORE ERROR THAN USUAL.
C -3, IF IN ORDER TO COMPLETE PHASE 1 IT WAS NECESSARY TO
C   TEMPORARILY RELAX THE RESTRICTION ON DIVISION BY NUMBERS
C   WITH SMALL ABSOLUTE VALUE.  THUS THERE IS AN INCREASED
C   CHANCE OF SERIOUS ROUNDOFF ERROR IN THE RESULTS.
C -4, IF A SOLUTION WAS FOUND NORMALLY, EXCEPT THAT REA AND REA1
C   WERE DECREASED BY A SIGNAL FROM THE CALLING PROGRAM (NAMELY
C   N=-N) IN ORDER TO TRY FOR MORE ACCURACY.  THIS INCREASES THE
C   CHANCES OF SERIOUS ROUNDOFF ERROR IN THE RESULTS.
C NOTE THAT INDIC=-3 WILL OVERWRITE (AND THUS CONCEAL) INDIC=-2
C   OR INDIC=-4, AND INDIC=-1 WILL OVERWRITE INDIC=-2, -3, OR -4
C
C SET MACHINE DEPENDENT PARAMETERS FOR SUBROUTINE SLNPRO.
C SET SPCMN=B**(-ITT), WHERE B IS THE BASE AND ITT IS THE NUMBER
C OF BASE B DIGITS IN THE MANTISSA.  SPCMN IS THE MINIMUM
C RELATIVE SPACING ABS((X1-X2)/X2) BETWEEN TWO SUCCESSIVE
C FLOATING POINT NUMBERS, SO IT IS THE SPACING BETWEEN TWO
C SUCCESSIVE FLOATING POINT NUMBERS IN THE CLOSED INTERVAL
C (0.1,1.0).  WE ALSO HAVE SPCMN=10.0**(-ITT*(LOG10)(B))=
C 10.0**(-TNMAN), WHERE TNMAN IS THE BASE 10 EQUIVALENT OF
C THE LENGTH OF THE MANTISSA.
C
C***FIRST EXECUTABLE STATEMENT  SLNPRO
      SPCMN=D1MACH(3)
C SET PRECISION DEPENDENT CONSTANTS FOR SLNPRO.
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
C SET REA (ROUND OFF ERROR ADJUSTMENT) =
C MAX(10.0**(-8),100.0*SPCMN).  THUS REA=10.0**(-EXREA),
C WHERE EXREA=MIN(8,TNMAN-2).
C DIVISION BY NUMBERS .LE. REA IN ABSOLUTE VALUE WILL NOT BE
C PERMITTED.
      REA=TEN*TEN*SPCMN
      IF(REA-TEN**(-8))10000,10010,10010
10000 REA=TEN**(-8)
C SET REA1=10.0*SPCMN.  THUS REA1=10.0**(-(TNMAN-1)).
C NUMBERS IN ROW M+1 OR COLUMN N+1 WHICH ARE .LE. REA1 IN
C ABSOLUTE VALUE WILL BE TREATED AS ZEROES.  SLNPRO ASSUMES
C THAT 0.0 .LT. REA1 .LE. REA.
10010 REA1=TEN*SPCMN
C END OF INITIAL SETTING OF MACHINE DEPENDENT PARAMETERS FOR
C SLNPRO.  THESE PARAMETERS MAY BE ADJUSTED BY A COMMAND FROM
C THE CALLING PROGRAM.
C
      INDIC=0
      LIMJOR=300
C M BEING NEGATIVE IS A SIGNAL TO INCREASE REA AND REA1,
C THUS TREATING MORE NUMBERS WITH SMALL ABSOLUTE VALUES AS
C ZEROES.  THIS MAY GIVE THIS ROUTINE A BETTER CHANCE TO
C SUCCEED, BUT MAY ALSO CAUSE LARGER ERRORS.
      IF(M)1001,10001,10001
C RESET M.
 1001 M=-M
      REA=SQRT(REA)
      REA1=SQRT(REA1)
      INDIC=-2
C N BEING NEGATIVE IS A SIGNAL TO DECREASE REA AND REA1 TO TRY
C FOR MORE ACCURACY.  AMONG OTHER THINGS, THIS MAKES IT MORE
C LIKELY THAT THE PREVIOUS VERTEX WILL BE RETAINED IN PHASE 1
C BELOW, BUT IT ALSO COULD INCREASE ROUND OFF ERROR.
10001 IF(N)10002,1002,1002
C RESET N.
10002 N=-N
      REA=REA1
      REA1=REA1/(TEN*TEN)
      INDIC=-4
C PRESERVE REA IN CASE IT MUST BE TEMPORARILY RELAXED.
C IRLAX=0 INDICATES REA IS NOT RELAXED AT THIS STAGE.
 1002 REAKP=REA
      IRLAX=0
C IN COLUMN N+1, NUMBERS .LE. REA2 IN ABSOLUTE VALUE WILL BE
C TREATED AS ZEROES.
      REA2=REA1
      NP1=N+1
      MP1=M+1
      KTJOR=0
      IBACK=0
C SET V(MP1,NP1)=0.0 SO THE DESCRIPTIONS IN AND FOLLOWING THE
C PROLOGUE WILL AGREE.
      V(MP1,NP1)=ZERO
C THE ONLY REASON FOR THE FOLLOWING THREE STATEMENTS IS TO
C AVOID THE ERROR MESSAGE ON SOME MACHINES THAT THESE
C VARIABLES HAVE NOT BEEN ASSIGNED A VALUE.  THEY WILL BE
C REASSIGNED A VALUE BEFORE THE PROGRAM REACHES A SPOT WHERE
C THEY WILL ACTUALLY BE USED.
      DIST=ONE
      AMPRV=ONE
      AMPR2=ONE
C SET IXRCT.  IXRCT(I)=0 MEANS SOME Y IS IN ROW I, WHILE
C IXRCT(I)=K.NE.0 MEANS X(K) IS IN ROW I.
      DO 1 I=1,M
        IXRCT(I)=0
    1   CONTINUE
C
C EXCHANGE THE XS AT THE TOP OF THE TABLE FOR YS.
C IF IYRCT(1) IS NONPOSITIVE, WE SET IYRCT AND CHOOSE THE
C LARGEST POSSIBLE RESOLVENTS FOR THE EXCHANGES.  IF
C IYRCT(1) IS POSITIVE, IYRCT WILL HAVE BEEN PREVIOUSLY SET
C AND WE TRY TO EXCHANGE IN ROWS IYRCT(1),...,IYRCT(N),
C STILL EMPLOYING A PIVOTING STRATEGY, BUT IF WE CANNOT, WE
C EXCHANGE IN ROWS IYRCT(N+1),...,IYRCT(M).
      IF(IYRCT(1))1003,1003,1005
 1003 I10=1
      I20=M
C IF WE HAVE NO INFORMATION FROM A PREVIOUS VERTEX, WE GIVE
C UP A LITTLE ACCURACY IN COLUMN N+1 TO HAVE A BETTER CHANCE
C OF SUCCESS.
      REA2=REA
C THIS ROUTINE HAS A BACKTRACKING OPTION WHICH SOMETIMES
C INCREASES ACCURACY BUT SOMETIMES LEADS TO FAILURE DUE TO
C CYCLING.  IT IS SUGGESTED THAT THIS OPTION BE EMPLOYED IF
C INFORMATION ABOUT A STARTING VERTEX IS AVAILABLE, AND
C OTHERWISE BE DISABLED BY SETTING IBACK=1.
      IBACK=1
      DO 1004 I=1,M
        IYRCT(I)=I
 1004   CONTINUE
      GO TO 1006
 1005 I10=1
      I20=N
 1006 J=0
C SET THE LOWER BOUND ON THE ABSOLUTE VALUE OF A RESOLVENT IN
C PHASE 1.  ALSO SET IFAIL=0 TO INDICATE THE RESOLVENT SEARCH
C IN THIS COLUMN HAS NOT FAILED.
      REA3=REA
      IFAIL=0
    2 J=J+1
      IF(J-N)1007,1007,9
C SET I1, I2 ACCORDING TO THE STRATEGY WE ARE USING.
 1007 I1=I10
      I2=I20
      AMAX=ZERO
C SEARCH FOR A RESOLVENT IN ROWS IYRCT(I1),...,IYRCT(I2).
10003 DO 1012 I=I1,I2
        IYTMP=IYRCT(I)
        IF(IXRCT(IYTMP))1012,1009,1012
 1009   ABSV=ABS(V(IYTMP,J))
        IF(ABSV-AMAX)1012,1012,1011
 1011   IYRI=IYTMP
        AMAX=ABSV
 1012   CONTINUE
C CHECK TO SEE IF THE PROSPECTIVE RESOLVENT IS LARGE ENOUGH
C IN ABSOLUTE VALUE.
      IF(AMAX-REA3)1013,1013,7
C EXCHANGE X(J) FOR Y(IYRI).
    7 CALL SJELIM(MP1,1,NP1,IYRI,J,NPARM,NUMGR,V)
      IXRCT(IYRI)=J
      IYCCT(J)=IYRI
C IYCCT(J)=IYRI MEANS Y(IYRI) IS IN COLUMN J.
C RESET REA3 AND IFAIL SINCE WE SUCCESSFULLY FOUND A RESOLVENT IN
C THIS COLUMN, AND THE RESOLVENT SEARCH IN THE NEXT COLUMN HAS
C NOT FAILED.
      REA3=REA
      IFAIL=0
      GO TO 2
C WE HAVE NOT FOUND A SUITABLE RESOLVENT IN ROWS IYRCT(I1),
C ...IYRCT(I2).  IF I2 .LT. M WE SEARCH THE REST OF COLUMN J.
 1013 IF(I2-M)1014,10004,10004
 1014 I1=I2+1
      I2=M
      GO TO 10003
C HERE WE FAILED TO FIND A RESOLVENT IN COLUMN J WITH ABSOLUTE
C VALUE .GT. REA3.  IF IFAIL=0 WE SET INDIC=-3 AND TRY AGAIN
C WITH REA3 REDUCED.  IF THIS HAS ALREADY BEEN TRIED WE SET
C INDIC=1 AND RETURN.
10004 IF(IFAIL)10005,10005,8
10005 IFAIL=1
      INDIC=-3
      REA3=REA1
      GO TO 1007
C
    8 INDIC=1
      RETURN
C
C REARRANGE THE ROWS OF V SO THAT X(1),...,X(N) COME FIRST
C IN THAT ORDER.  REDEFINE IYRCT SO THAT AFTER THE
C REARRANGEMENT IS DONE, IYRCT(I)=K WILL MEAN Y(K) IS IN
C ROW I (FOR I GREATER THAN N).
    9 DO 10 I=1,M
        IYRCT(I)=I
   10   CONTINUE
      IROW=0
   11 IROW=IROW+1
      IF(IROW-M)12,12,20
   12 IF(IXRCT(IROW))13,11,13
   13 IF(IXRCT(IROW)-IROW)14,11,14
C NOW X(L) IS IN ROW IROW, BUT WE WANT IT IN ROW L.
   14 L=IXRCT(IROW)
      LL=IXRCT(L)
      IF(LL)15,16,15
C X(L) IS IN ROW IROW, WHILE X(LL) IS IN ROW L.
   15 IXRCT(IROW)=LL
      IXRCT(L)=L
      GO TO 17
C X(L) IS IN ROW IROW, WHILE Y(IYRCT(L)) IS IN ROW L.
   16 IXRCT(IROW)=0
      IYRCT(IROW)=IYRCT(L)
      IXRCT(L)=L
C NOW EXCHANGE THE CONTENTS OF ROWS IROW AND L.
   17 DO 18 J=1,NP1
        TEMP=V(IROW,J)
        V(IROW,J)=V(L,J)
        V(L,J)=TEMP
   18   CONTINUE
      IF(IXRCT(IROW))19,11,19
   19 IF(IXRCT(IROW)-IROW)14,11,14
C NOW IXRCT IS NO LONGER NEEDED, SO STORE THE PRESENT IYCCT
C IN IT.
   20 DO 21 I=1,N
        IXRCT(I)=IYCCT(I)
   21   CONTINUE
C END OF PHASE 1.
C
C THE FIRST N ROWS OF V GIVE THE XS IN TERMS OF CERTAIN
C YS.  THESE ROWS WILL NOT BE CHANGED BY LATER OPERATIONS.
C
C WE NOW ATTACK THE MAXIMIZATION PROBLEM BY LOOKING AT THE
C DUAL PROBLEM OF MINIMIZING A FORM GIVEN BY THE
C COEFFICIENTS IN V(N+1,N+1) THROUGH V(M,N+1) WITH SLACK
C TERMS IN THE BOTTOM ROW OF V.
C SEARCH ROW M+1 FOR A SIGNIFICANTLY NEGATIVE ELEMENT.  IF
C THERE ARE NONE, PROCEED TO THE ACTUAL MINIMIZATION
C PROBLEM.  STICK WITH COLUMN JJ UNTIL V(M+1,JJ) .GE. -REA1.
      JJ=0
   22 JJ=JJ+1
      IF(JJ-N)1015,1015,1035
 1015 IF(V(MP1,JJ)+REA1)24,22,22
C
C WE HAVE V(M+1,JJ) SIGNIFICANTLY NEGATIVE.  SEARCH COLUMN
C JJ FOR A POSITIVE ELEMENT, TREATING A VERY SMALL V(I,J)
C AS A ZERO.  IF THERE ARE NO POSITIVE ELEMENTS THE DUAL
C CONSTRAINTS WERE INCONSISTENT, SO THE ORIGINAL PROBLEM WAS
C INCONSISTENT OR UNBOUNDED.
   24 I=N
      INAMP=0
   25 I=I+1
      IF(I-M)1016,1016,1020
 1016 IF(V(I,JJ)-REA)25,25,1017
C
C NOW V(I,JJ) .GT. REA.  WE SEARCH ROW I FOR INDICES K SUCH
C THAT V(M+1,K) .GE. 0.0.OR.K .LT. JJ, AND V(I,K) .LT. -REA, AND
C FIND THE MAXIMUM RATIO (I.E. THE RATIO WITH SMALLEST
C ABSOLUTE VALUE, IF V(M+1,K) .GE. 0.0) V(M+1,K)/V(I,K).  IF
C THERE IS NO SUCH K WE LOOK AT POSITIVE V(I,K) BELOW.
 1017 INDST=0
      DO 32 J=1,N
        IF(V(MP1,J))1018,28,28
 1018   IF(J-JJ)28,32,32
   28   IF(V(I,J)+REA)29,32,32
   29   DIST1=V(MP1,J)/V(I,J)
        IF(INDST)31,31,30
   30   IF(DIST1-DIST)32,32,31
   31   DIST=DIST1
        INDST=1
        K=J
   32   CONTINUE
      IF(INDST)35,35,33
C
C WE NOW COMPUTE V(I,JJ)*DIST AND GO ON TO LOOK AT OTHER
C ROWS TO MINIMIZE THIS QUANTITY (I.E. TO MAXIMIZE ITS
C ABSOLUTE VALUE, IF V(M+1,K) .GE. 0.0).  THIS IS THE NEGATIVE
C OF THE CHANGE IN V(M+1,JJ).
   33 BMPRV=V(I,JJ)*DIST
      IF(INAMP)34,34,1019
 1019 IF(BMPRV-AMPRV)34,25,25
   34 AMPRV=BMPRV
      INAMP=1
      KPMP1=I
      KPMP2=K
C (KPMP1,KPMP2) GIVES THE POSITION OF THE BEST PROSPECTIVE
C RESOLVENT FOUND SO FAR.
      GO TO 25
C
C IF THERE WAS NO INDEX K SUCH THAT V(M+1,K) .GE. 0.0.OR.K .LT.
C JJ, AND V(I,K) .LT. -REA, WE LOOK FOR THE SMALLEST (I.E.
C LARGEST IN ABSOLUTE VALUE) RATIO V(M+1,K)/V(I,K) FOR
C V(I,K) .GT. REA AND V(M+1,K) .LT. 0.0, AND PERFORM AN
C ELIMINATION WITH RESOLVENT V(I,K).  THERE IS AT LEAST ONE
C SUCH K, NAMELY JJ.
C THIS WILL FINISH PHASE 2 UNLESS BACKTRACKING IS NECESSARY.
   35 DIST=ONE
      DO 39 J=1,N
        IF(V(MP1,J))36,39,39
   36   IF(V(I,J)-REA)39,39,37
   37   DIST1=V(MP1,J)/V(I,J)
        IF(DIST1-DIST)38,39,39
   38   DIST=DIST1
        K=J
   39   CONTINUE
      GO TO 49
C
 1020 IF(INAMP)1021,1021,1023
C AT THIS POINT INAMP IS POSITIVE IFF THERE WAS AT LEAST ONE
C ELEMENT .GT. REA IN COLUMN JJ.  IF THERE WERE NONE, WE
C TEMPORARILY RELAX REA AND TRY AGAIN.
 1021 IF(IRLAX)1022,1022,41
 1022 IRLAX=1
      INDIC=-1
      REA=REA1
      GO TO 24
C
   41 INDIC=2
      RETURN
C
C CHECK TO SEE IF V(MP1,KPMP2) IS VERY SMALL IN ABSOLUTE
C VALUE OR NEGATIVE.  THIS INDICATES DEGENERACY.
 1023 IF(V(MP1,KPMP2)-REA)1024,1024,43
C DO AN ELIMINATION WITH RESOLVENT V(KPMP1,KPMP2).
   43 I=KPMP1
      K=KPMP2
      GO TO 49
C
C WE ARE NOW STUCK IN DEGENERATE COLUMN KPMP2.  WE SEARCH
C EACH DEGENERATE COLUMN IN WHICH WE ARE STUCK FOR A
C RESOLVENT WHICH WILL KEEP US FROM GETTING STUCK IN THIS
C COLUMN NEXT TIME, AND TO REDUCE THE ROUND-OFF ERROR WE
C TAKE THE SMALLEST OF THESE (I.E. LARGEST IN ABSOLUTE
C VALUE) AS OUR ACTUAL RESOLVENT.
 1024 AMIN=ONE
      DO 1034 J=1,N
C COLUMN J MAY BE DEGENERATE IF 0.0 .LE. V(M+1,J) .LE. REA,
C OR V(M+1,J) .LT. 0.0.AND.J .LT. JJ.
        IF(V(MP1,J))1025,1026,1026
 1025   IF(J-JJ)1027,1034,1034
 1026   IF(V(MP1,J)-REA)1027,1027,1034
C WE WILL BE STUCK IN COLUMN J IFF THERE IS AN INDEX ID FOR
C WHICH V(ID,JJ) .GT. REA AND V(ID,J) .LT. -REA.  IF THIS IS THE
C CASE, CHOOSING SUCH AN ID SO THAT V(ID,JJ)/V(ID,J) IS
C MINIMIZED (I.E. MAXIMIZED IN ABSOLUTE VALUE) AND TAKING
C V(ID,J) AS THE RESOLVENT WILL INSURE THAT WE DONT GET
C STUCK IN COLUMN J NEXT TIME.
 1027   DIST=ONE
        DO 1031 I=NP1,M
          IF(V(I,JJ)-REA)1031,1031,1028
 1028     IF(V(I,J)+REA)1029,1031,1031
 1029     DIST1=V(I,JJ)/V(I,J)
          IF(DIST1-DIST)1030,1031,1031
 1030     DIST=DIST1
          ID=I
 1031     CONTINUE
        IF(DIST-ONE/TWO)1032,1034,1034
C WE HAVE NOW DETERMINED THAT WE ARE STUCK IN COLUMN J.
C IF V(ID,J) .LT. AMIN THEN V(ID,J) IS THE BEST RESOLVENT
C FOUND SO FAR.
 1032   IF(V(ID,J)-AMIN)1033,1034,1034
 1033   AMIN=V(ID,J)
        KPMP1=ID
        KPMP2=J
 1034   CONTINUE
C THE BEST RESOLVENT IS V(KPMP1,KPMP2), SO WE DO AN
C ELIMINATION.
      GO TO 43
C
   49 KTJOR=KTJOR+1
      IF(KTJOR-LIMJOR)50,50,73
   50 CALL SJELIM(MP1,NP1,NP1,I,K,NPARM,NUMGR,V)
      ITEMP=IYRCT(I)
      IYRCT(I)=IYCCT(K)
      IYCCT(K)=ITEMP
C RESET REA AND IRLAX.
      REA=REAKP
      IRLAX=0
C IF NOW V(M+1,JJ) HAS BEEN MADE NOT SIGNIFICANTLY NEGATIVE,
C WE GO TO THE NEXT COLUMN.  OTHERWISE WE TRY AGAIN IN
C COLUMN JJ.
      IF(V(MP1,JJ)+REA1)24,22,22
C
C IN THE UNLIKELY EVENT THAT SOME V(M+1,J) IS STILL VERY
C SIGNIFICANTLY NEGATIVE WE BACKTRACK TO COLUMN J.  THIS
C COULD NOT HAPPEN IF THERE WERE NO ROUNDOFF ERROR AND WE
C COULD ALLOW DIVISION BY NUMBERS WITH VERY SMALL ABSOLUTE
C VALUE.  OMIT BACKTRACKING IF IBACK=1.
 1035 IF(IBACK)1036,1036,51
 1036 DO 1038 J=1,N
        IF(V(MP1,J)+REA)1037,1037,1038
 1037   JJ=J
        GO TO 24
 1038   CONTINUE
C END OF PHASE 2.
C
   51 I=N
      KKK=0
C
C SEARCH FOR A SIGNIFICANTLY NEGATIVE ELEMENT BETWEEN
C V(N+1,N+1) AND V(N+1,M).  IF THERE ARE NONE WE HAVE THE
C MINIMAL POINT OF THE DUAL PROBLEM (AND THUS THE MAXIMAL
C POINT OF THE DIRECT PROBLEM) ALREADY.
   52 I=I+1
      IF(I-M)1039,1039,1043
 1039 IF(V(I,NP1)+REA2)1040,52,52
C
C SEARCH FOR A NEGATIVE ELEMENT IN ROW I, TREATING A NUMBER
C WHICH IS VERY SMALL IN ABSOLUTE VALUE AS A ZERO.  IF THERE
C ARE NO NEGATIVE ELEMENTS THE DUAL PROBLEM WAS UNBOUNDED
C BELOW, SO THE ORIGINAL CONSTRAINTS WERE INCONSISTENT.
C FIND THE INDEX K OF THE LARGEST (I.E. SMALLEST IN ABSOLUTE
C VALUE, IF V(M+1,K) .GE. 0.0) RATIO V(M+1,K)/V(I,K) WITH
C V(I,K) .LT. -REA.
 1040 INDST=0
      DO 58 J=1,N
        IF(V(I,J)+REA)55,58,58
   55   DIST1=V(MP1,J)/V(I,J)
        IF(INDST)57,57,56
   56   IF(DIST1-DIST)58,58,57
   57   K=J
        INDST=1
        DIST=DIST1
   58   CONTINUE
      IF(INDST)1041,1041,60
C RELAX REA AND LOOK FOR NEGATIVE ELEMENTS WITH SMALLER
C ABSOLUTE VALUE.
 1041 IF(IRLAX)1042,1042,59
 1042 IRLAX=1
      INDIC=-1
      REA=REA1
      GO TO 1040
C
   59 INDIC=3
      RETURN
C
C COMPUTE THE IMPROVEMENT DIST*V(I,N+1) IN THE VALUE OF THE
C FORM USING V(I,K) AS THE RESOLVENT.  SET KKK=1 TO INDICATE
C A SIGNIFICANTLY NEGATIVE V(I,N+1) WAS FOUND, AND LOOK AT
C THE OTHER ROWS TO FIND THE RESOLVENT GIVING THE LARGEST
C IMPROVEMENT.
   60 BMPR2=DIST*V(I,NP1)
C RESET IRLAX SO THAT THE NEXT ROW WHICH NEEDS RELAXING DOES
C NOT TERMINATE THE ROUTINE.  REA WILL REMAIN RELAXED UNTIL
C AFTER THE NEXT ELIMINATION.
      IRLAX=0
      IF(KKK)62,62,61
   61 IF(BMPR2-AMPR2)52,52,62
   62 KKK=1
      KEEP=I
      KEEP1=K
      AMPR2=BMPR2
      GO TO 52
C KKK=0 HERE IFF NONE OF THE COST COEFFICIENTS ARE
C SIGNIFICANTLY NEGATIVE.
 1043 IF(KKK)1048,1044,1048
C CHECK TO SEE IF ANY OF THE NUMBERS IN THE BOTTOM ROW HAVE
C BECOME VERY SIGNIFICANTLY NEGATIVE.  IF SO, WE MUST
C BACKTRACK TO PHASE 2 (SEE COMMENT ABOVE STATEMENT 1035).
C OMIT BACKTRACKING IF IBACK=1.
 1044 IF(IBACK)1045,1045,74
 1045 DO 1047 J=1,N
        IF(V(MP1,J)+REA)1046,1046,1047
 1046   JJ=J
        GO TO 24
 1047   CONTINUE
      GO TO 74
C CHECK TO SEE IF V(MP1,KEEP1) IS VERY SMALL IN ABSOLUTE
C VALUE OR NEGATIVE.  THIS INDICATES DEGENERACY.
 1048 IF(V(MP1,KEEP1)-REA)1049,1049,65
C DO AN ELIMINATION WITH RESOLVENT V(KEEP,KEEP1).
   65 I=KEEP
      K=KEEP1
      GO TO 71
C
C WE ARE NOW STUCK IN DEGENERATE COLUMN KEEP1.  WE SEARCH
C EACH DEGENERATE COLUMN IN WHICH WE ARE STUCK FOR A
C RESOLVENT WHICH WILL KEEP US FROM GETTING STUCK IN THIS
C COLUMN NEXT TIME.  IF WE ARE NOT USING THE OPTION
C DESCRIBED IN THE COMMENTS PRECEDING STATEMENT 1055, WE
C TAKE THE SMALLEST OF THESE (I.E. THE LARGEST IN ABSOLUTE
C VALUE) AS OUR ACTUAL RESOLVENT IN ORDER TO REDUCE THE
C GROWTH OF ROUND-OFF ERROR.
 1049 AMIN=ONE
      MXRKN=NP1
      DO 1072 J=1,N
C COLUMN J MAY BE DEGENERATE IF V(M+1,J) .LE. REA.
        IF(V(MP1,J)-REA)1050,1050,1072
C WE WILL BE STUCK IN COLUMN J IFF THERE IS AN INDEX ID FOR
C WHICH V(ID,N+1) .LT. -REA2 AND V(ID,J) .LT. -REA.  IF THIS
C IS THE CASE, CHOOSING SUCH AN ID SO THAT V(ID,N+1)/V(ID,J)
C IS MAXIMIZED AND TAKING V(ID,J) AS THE RESOLVENT WILL
C INSURE THAT WE DONT GET STUCK IN COLUMN J NEXT TIME.
 1050   DIST=-ONE
        DO 1054 I=NP1,M
          IF(V(I,NP1)+REA2)1051,1054,1054
 1051     IF(V(I,J)+REA)1052,1054,1054
 1052     DIST1=V(I,NP1)/V(I,J)
          IF(DIST1-DIST)1054,1054,1053
 1053     DIST=DIST1
          ID=I
 1054     CONTINUE
        IF(DIST+ONE/TWO)1072,1072,1055
C
C WE HAVE NOW DETERMINED THAT WE ARE STUCK IN COLUMN J.
C THE FOLLOWING STATEMENTS ATTEMPT TO BREAK DEGENERACY
C FASTER BY LOOKING ONE ITERATION INTO THE FUTURE, THAT IS,
C BY CHOOSING FROM THE PROSPECTIVE RESOLVENTS FOUND ABOVE
C THAT ONE WHICH MINIMIZES THE MINIMUM NUMBER OF STICKING
C PLACES IN ANY ROW AT THE NEXT STAGE.
C BECAUSE OF COMPUTER TIME AND THE POSSIBLE LOSS OF ACCURACY
C DUE TO LESSENED PIVOTING (EVEN THOUGH TIES ARE ALWAYS
C BROKEN IN FAVOR OF THE RESOLVENT WITH GREATEST ABSOLUTE
C VALUE), IT IS SUGGESTED THAT THIS OPTION BE OMITTED IF
C INFORMATION WAS AVAILABLE FROM A PREVIOUS VERTEX.  THIS
C WILL BE THE CASE IFF THE BACKTRACKING OPTION WAS USED,
C THAT IS, IFF IBACK=0.
 1055   IF(IBACK)1070,1070,1056
C COMPUTE WHAT THE NEW BOTTOM ROW WOULD BE (EXCEPT FOR
C POSITION J) IF V(ID,J) WERE USED AS THE RESOLVENT, AND
C PUT THE RESULTS INTO Y.
 1056   ROWQ=V(MP1,J)/V(ID,J)
        DO 1058 L=1,N
          IF(L-J)1057,1058,1057
 1057     Y(L)=V(MP1,L)-V(ID,L)*ROWQ
 1058     CONTINUE
        LRKNT=-1
C WE LOOK FOR A ROW WHICH WILL HAVE A SIGNIFICANTLY NEGATIVE
C LAST ELEMENT BUT A MINIMUM NUMBER OF PLACES WHERE WE WILL
C BE STUCK IN DEGENERATE COLUMNS.  LRKNT=-1 MEANS WE HAVE
C NOT YET FOUND A ROW WHICH WILL HAVE A SIGNIFICANTLY
C NEGATIVE LAST ELEMENT.
        DO 1068 II=NP1,M
          IF(II-ID)1059,1068,1059
 1059     ROWQ=V(II,J)/V(ID,J)
          RTCOL=V(II,NP1)-V(ID,NP1)*ROWQ
          IF(RTCOL+REA2)1060,1068,1068
C IF WE HAVE ALREADY LOCATED A RESOLVENT WHICH WILL FINISH
C THE ROUTINE, BUT THE PRESENT PROSPECTIVE RESOLVENT WOULD
C GIVE A ROW WITH A SIGNIFICANTLY NEGATIVE LAST ELEMENT, WE
C LOOK AT THE NEXT PROSPECTIVE RESOLVENT FOR PIVOTING
C PURPOSES.
 1060     IF(MXRKN+1)1061,1072,1061
 1061     LRKNT=0
C NOW COUNT THE NUMBER (LRKNT) OF STICKING PLACES IN ROW II
C AT THE NEXT ITERATION.
          DO 1065 JJ=1,N
            IF(JJ-J)1062,1065,1062
 1062       IF(Y(JJ)-REA)1063,1063,1065
 1063       IF(V(II,JJ)-V(ID,JJ)*ROWQ+REA)1064,1065,1065
 1064       LRKNT=LRKNT+1
            IF(LRKNT-MXRKN)1065,1065,1068
 1065       CONTINUE
          IF(LRKNT-MXRKN)1067,1066,1068
 1066     IF(V(ID,J)-AMIN)1067,1068,1068
 1067     MXRKN=LRKNT
          AMIN=V(ID,J)
          KEEP=ID
          KEEP1=J
 1068     CONTINUE
C LRKNT=-1 HERE WOULD MEAN THIS RESOLVENT WOULD FINISH THE
C ROUTINE.  IF LRKNT .GE. 0 THEN MXRKN .GE. 0 ALSO, SO WE WILL
C NOT HAVE EARLIER FOUND A RESOLVENT WHICH WILL FINISH THE
C ROUTINE.
        IF(LRKNT+1)1072,1069,1072
 1069   IF(MXRKN+1)1071,1070,1071
 1070   IF(V(ID,J)-AMIN)1071,1072,1072
 1071   MXRKN=-1
        AMIN=V(ID,J)
        KEEP=ID
        KEEP1=J
 1072   CONTINUE
C THE BEST RESOLVENT IS V(KEEP,KEEP1), SO WE DO AN
C ELIMINATION.
      GO TO 65
C
   71 KTJOR=KTJOR+1
      IF(KTJOR-LIMJOR)72,72,73
   72 CALL SJELIM(MP1,NP1,NP1,I,K,NPARM,NUMGR,V)
      ITEMP=IYRCT(I)
      IYRCT(I)=IYCCT(K)
      IYCCT(K)=ITEMP
C RESET REA AND IRLAX.
      REA=REAKP
      IRLAX=0
      GO TO 51
C
   73 INDIC=4
      RETURN
C END OF PHASE 3.  WE NOW HAVE THE VERTEX WE ARE SEEKING.
C
C READ OFF THE Y VALUES FOR THIS VERTEX.
   74 DO 75 J=1,N
        IYCJ=IYCCT(J)
        Y(IYCJ)=ZERO
   75   CONTINUE
      DO 76 I=NP1,M
        IYRI=IYRCT(I)
        Y(IYRI)=V(I,NP1)
   76   CONTINUE
C COMPUTE THE XS FROM THE YS.  RECALL THAT IXRCT CONTAINS
C THE FORMER IYCCT.
      DO 78 I=1,N
        X(I)=V(I,NP1)
        DO 77 J=1,N
          IXRJ=IXRCT(J)
          X(I)=X(I)-V(I,J)*Y(IXRJ)
   77     CONTINUE
   78   CONTINUE
C
C NOW PUT THE VALUES IN IYCCT INTO THE FIRST N POSITIONS OF
C IYRCT IN DECREASING ORDER.
C TO ACCOMPLISH THIS, MAKE IXRCT(I)=-1 IF IYCCT(J)=I FOR
C SOME J, THEN SCAN IXRCT BACKWARDS.
      DO 79 J=1,N
        IYCJ=IYCCT(J)
        IXRCT(IYCJ)=-1
   79   CONTINUE
      K=1
      I=MP1
   80 I=I-1
      IF(I)83,83,81
   81 IF(IXRCT(I)+1)80,82,80
   82 IYRCT(K)=I
      K=K+1
      GO TO 80
C NOW FILL IN THE REST OF IYRCT BY SCANNING IXRCT AGAIN.
   83 I=MP1
   84 I=I-1
      IF(I)87,87,85
   85 IF(IXRCT(I))84,86,86
   86 IYRCT(K)=I
      K=K+1
      GO TO 84
   87 RETURN
      END
      SUBROUTINE SJELIM(L,LL,K,IR,IS,NPARM,NUMGR,V)
C***BEGIN PROLOGUE  SJELIM
C***REFER TO  SLNPRO
C***ROUTINES CALLED  (NONE)
C***PURPOSE  THIS SUBROUTINE PERFORMS A MODIFIED JORDAN
C            ELIMINATION ON THE L-LL+1 BY K MATRIX
C            CONSISTING OF ROWS LL THROUGH L OF V AND
C            COLUMNS 1 THROUGH K OF V.  THE RESOLVENT
C            IS V(IR,IS).
C***END PROLOGUE  SJELIM
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION V(NUMGR+2*NPARM+1,NPARM+2)
C
C SET PRECISION DEPENDENT CONSTANTS FOR SJELIM.
C***FIRST EXECUTABLE STATEMENT  SJELIM
      ONE=1.0D0
C EMD OF SETTING PRECISION DEPENDENT CONSTANTS FOR SJELIM.
C
C DIVIDE THE ENTRIES IN THE RESOLVENT ROW (EXCEPT FOR THE
C RESOLVENT) BY THE RESOLVENT.
      RESOL=V(IR,IS)
      DO 2 J=1,K
        IF(J-IS)1001,2,1001
 1001   V(IR,J)=V(IR,J)/RESOL
    2   CONTINUE
C SWEEP OUT IN ALL BUT ROW IR AND COLUMN IS.
      DO 6 I=LL,L
        IF(I-IR)1002,6,1002
 1002   FACT=-V(I,IS)
        DO 5 J=1,K
          IF(J-IS)1003,5,1003
 1003     V(I,J)=V(I,J)+V(IR,J)*FACT
    5     CONTINUE
    6   CONTINUE
C DIVIDE THE ENTRIES IN THE RESOLVENT COLUMN (EXCEPT FOR THE
C RESOLVENT) BY THE NEGATIVE OF THE RESOLVENT.
      DO 8 I=LL,L
        IF(I-IR)1004,8,1004
 1004   V(I,IS)=-V(I,IS)/RESOL
    8   CONTINUE
C REPLACE THE RESOLVENT BY ITS RECIPROCAL.
      V(IR,IS)=ONE/RESOL
      RETURN
      END
      SUBROUTINE SEARSL(IOPTN,NUMGR,NPARM,PRJLIM,TOL1,X,FUN,IFUN,
     *PTTBL,IPTB,INDM,PARAM,ERROR,RCHDWN,MACT,IACT,IPHSE,UNIT,
     *TOLCON,RCHIN,ITYPM1,ITYPM2,IWORK,LIWRK,WORK,LWRK,ERR1,PARPRJ,
     *PROJCT,EMIN,EMIN1,PARSER,NSRCH)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),PARAM(NPARM),ERR1(NUMGR+3),
     *PARPRJ(NPARM),X(NPARM+1),ERROR(NUMGR+3),
     *IACT(NUMGR),PARSER(NPARM),IWORK(LIWRK),WORK(LWRK)
C
C THIS SUBROUTINE USES A MODIFIED QUADRATIC FITTING PROCESS TO
C SEARCH FOR THE MINIMUM OF A FUNCTION F.  IT REQURES AN INITIAL
C GUESS IN PROJCT, A TOLERANCE TOL1 ON THE SEARCH INTERVAL LENGTH,
C AN UPPER BOUND PRJLIM ON THE MINIMIZING POINT (WHICH SHOULD BE SET
C VERY LARGE IF NO UPPER BOUND IS DESIRED), AND A WAY TO COMPUTE F(X)
C FOR A GIVEN X.  THE SUBROUTINE WILL PRINT A WARNING AND RETURN IF
C IT WOULD NEED TO COMPUTE F MORE THAN INITLM TIMES IN THE INITIALIZATION
C OR MORE THAN NADD ADDITIONAL TIMES IN THE MAIN PART OF THE PROGRAM.
C WHEN THE SUBROUTINE RETURNS, IT WILL HAVE PUT THE MINIMUM LOCATION IN
C PROJCT, THE MINIMUM F VALUE IN EMIN, THE F VALUE FOR THE INITIAL
C PROJCT IN EMIN1, AND THE NUMBER OF TIMES IT COMPUTED F IN NSRCH.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR SEARSL.
      ONE=1.0D0
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
C     NWRIT=I1MACH(2)
      SPCMN=D1MACH(3)
      BIG=ONE/SPCMN
      TOLDEN=TEN*SPCMN
      TOL4=TOL1/FOUR
      BALFCT=TEN
      BALADJ=(TEN-ONE)/TEN
      ILC08=ILOC(8,NPARM,NUMGR)
      ILC10=ILOC(10,NPARM,NUMGR)
      ILC17=ILOC(17,NPARM,NUMGR)
      ILC21=ILOC(21,NPARM,NUMGR)
      ILC27=ILOC(27,NPARM,NUMGR)
      ILC29=ILOC(29,NPARM,NUMGR)
      ILC48=ILOC(48,NPARM,NUMGR)
C
C THE INITIAL PROJCT CAN BE INCREASED (OR DECREASED) BY A FACTOR OF
C 2.0**((INITLM-1)*INITLM-2)/2) (ASSUMING WE TAKE INITLM .GE. 3, AS
C WE SHOULD).  WE TAKE INITLM=6 SINCE A FACTOR OF 1024 SEEMS SUFFICIENT.
      INITLM=6
C NADD=4 SEEMS TO BE SUFFICIENT SINCE THIS NUMBER OF ITERATIONS PAST THE
C INITIALIZATION SEEMS TO ONLY RARELY BE EXCEEDED.
      NADD=4
      NSRCH=0
      ILF=0
      IRT=0
      IUPBAR=0
      ISAVE=0
C INITIALLY PUT PARAM IN PARSER SO THERE WILL BE SOMETHING THERE IF
C WE NEVER GET A CORRECTIBLE PARPRJ.
      DO 55 J=1,NPARM
        PARSER(J)=PARAM(J)
   55   CONTINUE
C WE NOW TRY TO COMPUTE VALUES AT POINTS P2=PROJCT, P1=P2/2.0, AND
C P3=2.0*P2 (BUT P3 CANNOT EXCEED PRJLIM).
      P2=PROJCT
C SET LLL=2 AS THE THREAD THROUGH THE MINOTAURS CAVERN AND JUMP
C DOWN TO PUT F(P2) IN F2.  WE WILL JUMP BACK AFTER ALL SUCH JUMPS
      LLL=2
      PVAL=P2
      GO TO 3500
C
   77 F2=FVAL
C SET EMIN1 = THE VALUE OF F USING THE GIVEN PROJECTION FACTOR PROJCT.
      EMIN1=FVAL
      P1=P2/TWO
C SET LLL=1 AND PUT F(P1) IN F1.
      LLL=1
      PVAL=P1
      GO TO 3500
C
   97 F1=FVAL
      P3=TWO*P2
C IF P3 .GT. PRJLIM, SET IUPBAR=1 AS AN INDICATOR WE CANNOT LATER
C EXPAND THE INTERVAL TO THE RIGHT.  THEN IF PRJLIM .GE. P2+TOL4
C REPLACE P3 BY PRJLIM, AND OTHERWISE EXPAND THE INTERVAL TO THE
C LEFT TO GET THE DESIRED THIRD POINT.
      IF(P3-PRJLIM)160,160,120
  120 IUPBAR=1
      IF(PRJLIM-P2-TOL4)220,140,140
  140 P3=PRJLIM
C HERE SET LLL=3 AND PUT F(P3) IN F3.
  160 LLL=3
      PVAL=P3
      GO TO 3500
C
  187 F3=FVAL
      GO TO 280
C
C EXPAND LEFT TO GET THE INITIAL THIRD POINT SINCE THERE IS NO ROOM
C TO EXPAND RIGHT.
  220 P3=P2
      F3=F2
      P2=P1
      F2=F1
      P1=P1/TWO
C SET LLL=4 AND PUT F(P1) IN F1.
      LLL=4
      PVAL=P1
      GO TO 3500
C
  247 F1=FVAL
C
C WE NOW HAVE FOUND P1, P2, AND P3 WITH CORRESPONDING VALUES
C F1, F2, AND F3.  WE EXPAND THE INTERVAL IF NECESSARY TO TRY
C TO FIND NEW VALUES WITH F2 .LE. MIN(F1,F3).
  280 IF(F2-F1)500,500,300
  300 IF(F1-F3)320,320,520
C
C HERE WE WILL EXPAND THE INTERVAL TO THE LEFT, PROVIDING THAT
C NSRCH .LT. INITLM AND P1-P1/2.0**(NSRCH-1) .GE. TOL4.
  320 IF(NSRCH-INITLM)340,360,360
  340 IF(P1-P1/TWO**(NSRCH-1)-TOL4)360,380,380
C
C HERE WE CANNOT EXPAND LEFT AND WE RETURN WITH THE BEST VALUES
C FOUND SO FAR.
  360 PROJCT=P1
      EMIN=F1
      RETURN
C
C EXPAND LEFT.
  380 P3=P2
      F3=F2
      P2=P1
      F2=F1
      P1=P1/TWO**(NSRCH-1)
C SET LLL=5 AND PUT F(P1) IN F1.
      LLL=5
      PVAL=P1
      GO TO 3500
  407 F1=FVAL
C
C HERE F2 .LE. F3 AND WE HAVE JUST EXPANDED LEFT.  IF F2 .GT. F1 WE
C TRY TO EXPAND LEFT AGAIN, OTHERWISE WE CHECK TO SEE IF WE ARE DONE
C INITIALIZING.
      IF(F2-F1)440,440,320
C
C HERE WE CHECK TO SEE IF THE F COMPUTATION HAS FAILED EVERY TIME
C (INDICATED BY F1=F2=F3=BIG), AND IF SO WE TRY TO EXPAND LEFT.
C IF NOT, WE ARE DONE WITH THE INITIALIZATION.
  440 IF(F1-BIG)1100,460,460
  460 IF(F2-BIG)1100,480,480
  480 IF(F3-BIG)1100,320,320
C
C HERE F2 .LE. F1.  IF F2 .LE. F3 AND WE HAVE NOT HAD ALL FAILURES OF
C THE F COMPUTATION, WE ARE DONE INITIALIZING.
  500 IF(F2-F3)440,440,520
C
C HERE F3 .LT. MIN(F1,F2) AND WE EXPAND THE INTERVAL TO THE RIGHT IF
C NSRCH .LT. INITLM AND IUPBAR=0.
  520 IF(NSRCH-INITLM)540,560,560
  540 IF(IUPBAR)580,580,560
C
C HERE WE CANNOT EXPAND RIGHT AND WE RETURN WITH THE BEST VALUES
C FOUND SO FAR.
  560 PROJCT=P3
      EMIN=F3
      RETURN
C
C EXPAND RIGHT.
  580 P1=P2
      F1=F2
      P2=P3
      F2=F3
      P3=TWO**(NSRCH-1)*P2
C IF P3 .GT. PRJLIM, SET IUPBAR=1 AS AN INDICATOR WE CANNOT LATER
C EXPAND THE INTERVAL TO THE RIGHT.  THEN IF PRJLIM .GE. P2+TOL4
C REPLACE P3 BY PRJLIM, AND OTHERWISE RETURN WITH THE BEST VALUES
C FOUND SO FAR.
      IF(P3-PRJLIM)660,660,600
  600 IUPBAR=1
      IF(PRJLIM-P2-TOL4)620,640,640
  620 PROJCT=P2
      EMIN=F2
      RETURN
C
  640 P3=PRJLIM
C
C SET LLL=6 AND PUT F(P3) IN F3.
  660 LLL=6
      PVAL=P3
      GO TO 3500
  687 F3=FVAL
C
C HERE F2 .LT. F1 AND WE HAVE JUST EXPANDED RIGHT.  IF F2 .LE. F3
C WE ARE DONE INITIALIZING, OTHERWISE WE TRY TO EXPAND RIGHT AGAIN.
      IF(F2-F3)1100,1100,520
C END OF INITIALIZATION.
C
C ASSUMING THAT P3-P1 .GE. TOL1, WE NOW HAVE POINTS P1, P2, P3 WITH
C P1 .LE. P2-TOL4, P2 .LE. P3-TOL4, F1=F(P1) .GE. F2=F(P2), AND F3=F(P3)
C .GE. F2.  THESE CONDITIONS WILL BE MAINTAINED THROUGHOUT THE PROGRAM.
C SET LLL=7, WHERE IT WILL REMAIN FROM NOW ON.
 1100 LLL=7
C
C RESET LIMS1 SO THAT AT MOST NADD MORE COMPUTATIONS OF F WILL BE DONE.
      LIMS1=NSRCH+NADD
C
C IF WE HAVE COMPUTED F LIMS1 TIMES, WE PUT P2 IN PROJCT, PUT F2 IN
C EMIN, AND RETURN.
 1200 IF(NSRCH-LIMS1)1250,1300,1300
C
C IF THE SEARCH INTERVAL LENGTH IS LESS THAN TOL1 WE PUT P2 IN
C PROJCT, PUT F2 IN EMIN, AND RETURN.
 1250 IF(P3-P1-TOL1)1300,1400,1400
C
 1300 PROJCT=P2
      EMIN=F2
      RETURN
C
C COMPUTE S1 = THE ABSOLUTE VALUE OF THE SLOPE OF THE LINE THROUGH
C (P1,F1) AND (P2,F2), AND S2 = THE (ABSOLUTE VALUE OF THE) SLOPE
C OF THE LINE THROUGH (P2,F2) AND (P3,F3).
C***MOD  CONSIDER INCREASING TOL1 TO 10**4*SPCMN
 1400 S1=(F1-F2)/(P2-P1)
      S2=(F3-F2)/(P3-P2)
C IF S1+S2 IS VERY SMALL WE RETURN WITH THE BEST VALUES FOUND SO FAR.
      IF(S1+S2-TOLDEN)1300,1600,1600
C
 1600 RLF=S2/(S1+S2)
      RRT=ONE-RLF
C THE MINIMUM OF THE QUADRATIC POLYNOMIAL PASSING THROUGH
C (P1,F1), (P2,F2), AND (P3,F3) WILL OCCUR AT (RLF*P1+
C RRT*P3+P2)/2.0.  NOTE THAT THE THREE POINTS CANNOT BE
C COLLNEAR, ELSE WE WOULD HAVE TERMINATED ABOVE.  SINCE THE
C MINIMUM OCCURS AT THE AVERAGE OF P2 AND A CONVEX COMBINATION
C OF P1 AND P3, IT WILL BE AT LEAST AS CLOSE TO P2 AS TO THE
C ENDPOINT ON THE SAME SIDE.
      IF(ILF-1)1800,1800,1700
C
C HERE THE LEFT ENDPOINT WAS DROPPED AT THE LAST ILF .GT. 1
C ITERATIONS, SO TO PREVENT A LONG STRING OF SUCH OCCURRENCES
C WITH LITTLE REDUCTION OF P3-P1 WE WILL SHIFT THE NEW POINT
C TO THE RIGHT BY DECREASING RLF RELATIVE TO RRT.
 1700 RLF=RLF/TWO**(ILF-1)
      RRT=ONE-RLF
      GO TO 2400
 1800 IF(IRT-1)2000,2000,1900
C
C HERE THE RIGHT ENDPOINT WAS DROPPED AT THE LAST IRT .GT. 1
C ITERATIONS, AND WE WILL SHIFT THE NEW POINT TO THE LEFT.
 1900 RRT=RRT/TWO**(IRT-1)
      RLF=ONE-RRT
      GO TO 2400
C
C HERE WE HAVE NOT JUST HAD A STRING OF TWO OR MORE MOVES IN
C THE SAME DIRECTION, BUT IF THE SUBINTERVALS ARE OUT OF
C BALANCE BY MORE THAN A FACTOR OF BALFCT, WE SHIFT THE NEW
C POINT SLIGHTLY IN THE DIRECTION OF THE LONGER INTERVAL.  THE
C IDEA HERE IS THAT THE TWO CLOSE POINTS ARE PROBABLY NEAR THE
C SOLUTION, AND IF WE CAN BRACKET THE SOLUTION WE MAY BE ABLE TO
C CUT OFF THE MAJOR PORTION OF THE LONGER SUBINTERVAL.
 2000 IF(P2-P1-BALFCT*(P3-P2))2200,2200,2100
C
C HERE THE LEFT SUBINTERVAL IS MORE THAN BALFCT TIMES LONGER THAN
C THE RIGHT SUBINTERVAL, SO WE DECREASE RRT RRELATIVE TO RLF.
 2100 RRT=BALADJ*RRT
      RLF=ONE-RRT
      GO TO 2400
 2200 IF(P3-P2-BALFCT*(P2-P1))2400,2400,2300
C
C HERE THE RIGHT SUBINTERVAL IS MORE THAN BALFCT TIMES LONGER
C THAN THE LEFT SUBINTERVAL, SO WE DECREASE RLF RELATIVE TO RRT.
 2300 RLF=BALADJ*RLF
      RRT=ONE-RLF
C
C COMPUTE THE (POSSIBLY MODIFIED) MINIMUM OF THE QUADRATIC FIT.
 2400 P4=(RLF*P1+RRT*P3+P2)/TWO
C
C THE NEXT SECTION (FROM HERE TO STATEMENT 2800) MODIFIES P4 IF NECESSARY
C TO GET P1+TOL4 .LE. P2,P4 .LE. P3-TOL4 AND ABS(P4-P2) .GE. TOL4.  IN
C THE UNLIKELY EVENT THIS IS NOT POSSIBLE WE SET PROJCT=P2, EMIN=F2
C AND RETURN.
C
C IF ABS(P4-P2) .LT. TOL4 WE REDEFINE P4 BY MOVING TOL4 FROM
C P2 INTO THE LONGER SUBINTERVAL.  NOTE THAT THE LENGTH OF THIS
C SUBINTERVAL MUST BE AT LEAST TOL1/2.0 = 2.0*TOL4, ELSE WE
C WOULD HAVE TERMINATED EARLIER.
      IF(ABS(P4-P2)-TOL4)2500,2710,2710
 2500 IF(P3-P2-(P2-P1))2700,2700,2600
 2600 P4=P2+TOL4
C IF TOL4 WAS SMALL ENOUGH RELATIVE TO P2 THAT THE MACHINE THINKS P4
C STILL EQUALS P2, WHICH IS MORE LIKELY IF P2 IS LARGE, THIS COULD RESULT
C IN A DIVIDE FAULT LATER.  TO AVOID THIS, WE REDEFINE P4 AS THE AVERAGE
C OF P2 AND P3 IF NECESSARY.  IF WE STILL DONT HAVE P4 STRICTLY BETWEEN
C P2 AND P3, WE TERMINATE THE SEARCH.
      IF(P4-P2)2620,2620,2640
 2620 P4=(P2+P3)/TWO
      IF(P4-P2)1300,1300,2640
 2640 IF(P4-P3)2800,1300,1300
 2700 P4=P2-TOL4
C IF TOL4 WAS SMALL ENOUGH RELATIVE TO P2 THAT THE MACHINE THINKS P4
C STILL EQUALS P2, WHICH IS MORE LIKELY IF P2 IS LARGE, THIS COULD RESULT
C IN A DIVIDE FAULT LATER.  TO AVOID THIS, WE REDEFINE P4 AS THE AVERAGE
C OF P1 AND P2 IF NECESSARY.  IF WE STILL DONT HAVE P4 STRICTLY BETWEEN
C P1 AND P2, WE TERMINATE THE SEARCH.
      IF(P4-P2)2704,2702,2702
 2702 P4=(P1+P2)/TWO
      IF(P4-P2)2704,1300,1300
 2704 IF(P4-P1)1300,1300,2800
C HERE WE HAD ABS(P4-P2) .GE. TOL4 AND WE MAKE SURE THAT P1+TOL4
C .LE. P4 .LE. P3-TOL4.
 2710 IF(P4-(P3-TOL4))2740,2740,2720
C HERE P4 .GT. P3-TOL4 AND WE SET P4=P3-TOL4 IF P3-P2 .GE. TOL1/2.0,
C AND OTHERWISE WE SET P4=P2-TOL4.
 2720 IF(P3-P2-TOL1/TWO)2700,2730,2730
 2730 P4=P3-TOL4
      GO TO 2800
 2740 IF(P4-(P1+TOL4))2750,2800,2800
C HERE P4 .LT. P1+TOL4 AND WE SET P4=P1+TOL4 IF P2-P1 .GE. TOL1/2.0
C AND OTHERWISE WE SET P4=P2+TOL4.
 2750 IF(P2-P1-TOL1/TWO)2600,2760,2760
 2760 P4=P1+TOL4
C
C NOW JUMP DOWN TO PUT F(P4) IN F4.
 2800 PVAL=P4
      GO TO 3500
C
 2877 F4=FVAL
C
C NOW WE DROP EITHER P1 OR P3 AND RELABEL THE REMAINING POINTS SO
C THAT F(P2) .LE. F(P1) AND F(P2) .LE. F(P3).
C
C IF NOW THE LEFTMOST OF THE TWO MIDDLE POINTS IS LOWER THAN THE
C RIGHTMOST OF THE TWO MIDDLE POINTS WE DROP P3, AND SET ILF=0
C AND INCREMENT IRT TO INDICATE THE RIGHT END POINT HAS BEEN DROPPED.
C OTHERWISE WE DROP P1, SET IRT=0 AND INCREMENT ILF.  IN ALL CASES
C WE THEN RESHUFFLE THE VALUES INTO P1, P2, P3, F1, F2, F3 AND TRY
C TO DO ANOTHER ITERATION.
      IF(P4-P2)2900,3200,3200
C
C HERE P4 .LT. P2.
 2900 IF(F4-F2)3000,3100,3100
 3000 P3=P2
      F3=F2
      P2=P4
      F2=F4
      ILF=0
      IRT=IRT+1
      GO TO 1200
 3100 P1=P4
      F1=F4
      ILF=ILF+1
      IRT=0
      GO TO 1200
C
C HERE P4 .GT. P2.
 3200 IF(F2-F4)3300,3400,3400
 3300 P3=P4
      F3=F4
      ILF=0
      IRT=IRT+1
      GO TO 1200
 3400 P1=P2
      F1=F2
      P2=P4
      F2=F4
      ILF=ILF+1
      IRT=0
      GO TO 1200
C
C INCREMENT NSRCH SINCE WE ARE ABOUT TO COMPUTE F.
 3500 NSRCH=NSRCH+1
C
C
C THIS IS WHERE THE USER MUST SUPPLY A ROUTINE TO COMPUTE
C FVAL=F(PVAL).  IF THE PROCEDURE FAILS, SET FVAL=BIG.
C
      FVAL=BIG
C PROJECT X TO GET PARPRJ.
      DO 4000 J=1,NPARM
        PARPRJ(J)=PARAM(J)+PVAL*X(J)
 4000   CONTINUE
C
C CALL CORRCT TO RETURN PARPRJ TO FEASIBILITY IF NECESSARY IF ITYPM1
C OR ITYPM2 IS POSITIVE.
      IF(ITYPM1+ITYPM2)10070,10070,4020
 4020 CALL CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *IWORK(ILC17),UNIT,TOLCON,RCHIN,ERROR,MACT,IACT,
     *PROJCT,IPHSE,IWORK,LIWRK,WORK,LWRK,WORK(ILC27),ERR1,WORK(ILC10),
     *WORK(ILC29),WORK(ILC08),WORK(ILC48),IWORK(ILC21),PARPRJ,ICORCT)
      IF(ICORCT)10070,10070,10100
10070 CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARPRJ,1,IPHSE,IWORK,LIWRK,WORK(ILC08),IWORK(ILC17),IPMAX,
     *ISMAX,ERR1)
      FVAL=ERR1(NUMGR+1)
C
C IF NSRCH=1, INDICATING THAT WE ARE COMPUTING F WITH THE INITIAL PROJCT,
C CALL RCHMOD WITH IRCH=1 TO INCREASE RCHDWN FOR THE NEXT SETU1 OR
C RKSACT CALL IF NECESSARY.
      IF(NSRCH-1)10071,10071,10073
10071 CALL RCHMOD(NUMGR,ERROR,ERR1,IWORK(ILC17),MACT,IACT,
     *IPMAX,ISMAX,UNIT,1,RCHDWN,RCHIN)
C WE WILL SAVE THE BEST PARPRJ FOUND IN THIS SEARSL CALL IN PARSER.
10073 IF(ISAVE)10080,10080,10075
10075 IF(FVAL-FVLKP)10085,10100,10100
10080 ISAVE=1
10085 DO 10090 J=1,NPARM
        PARSER(J)=PARPRJ(J)
10090   CONTINUE
      FVLKP=FVAL
C IF IPHSE .LT. 0 AND FVAL .LE. TOLCON WE RETURN WITH THE BEST VALUES
C FOUND SO FAR.
      IF(IPHSE)10093,10100,10100
10093 IF(FVAL-TOLCON)10097,10097,10100
10097 PROJCT=PVAL
      EMIN=FVAL
      RETURN
C
C CARRY THE COMPUTED F VALUE BACK TO THE APPROPRIATE PART OF THE PROGRAM.
10100 GO TO (97,77,187,247,407,687,2877),LLL
      END
      SUBROUTINE ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,
     *INDM,PARAM,ICNUSE,IPHSE,IWORK,LIWRK,CONFUN,ICNTYP,IPMAX,
     *ISMAX,ERROR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),PARAM(NPARM),ICNTYP(NUMGR),
     *ERROR(NUMGR+3),CONFUN(NUMGR,NPARM+1),IWORK(LIWRK)
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      ILC22=ILOC(22,NPARM,NUMGR)
      IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
      IF(IOPTTH)100,100,1700
C
C HERE IOPTTH=0, AND EACH CALL TO FNSET WILL COMPUTE FUNCTION VALUES
C FOR ONLY ONE CONSTRAINT.
  100 DO 1600 I=1,NUMGR
        IPT=I
        IF(ICNUSE)200,200,600
C
C HERE ICNUSE=0 SO WE WILL ACCEPT AND USE THE ICNTYP(I) COMPUTED BY
C FNSET.
C CALL FNSET WITH INDFN=0 TO COMPUTE CONFUN(I,1) AND ICNTYP(I).
  200   CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,0,
     *  ICNTYP,CONFUN)
        GO TO 1100
C
C HERE ICNUSE=1 AND THE ICNTYP CARRIED INTO ERCMP1 WILL OVERRIDE THAT
C COMPUTED BY FNSET.  THIS WILL ALSO BE TRUE IN ALL SUBROUTINES OTHER
C THAN CONMAX.  IF ICNTYP(I)=0 WE WILL SET ERROR(I)=0.0 AND WILL NOT
C NEED TO CALL FNSET.
  600   IF(ICNTYP(I))700,1200,700
C
C CALL FNSET WITH INDFN=0 TO COMPUTE CONFUN(I,1).  THE COMPUTED KCNTYP
C WILL NOT BE USED.
  700   CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,0,
     *  IWORK(ILC22),CONFUN)
C
C SET ERROR(I)=0.0, OR CONFUN(I,1), OR FUN(I) - CONFUN(I,1) ACCORDING AS
C ICNTYP(I) IS 0, OR -2, -1, 1, OR 2.
 1100   IF(ICNTYP(I))1400,1200,1300
C
 1200   ERROR(I)=ZERO
        GO TO 1600
C
 1300   IF(ICNTYP(I)-1)1400,1400,1500
C
 1400   ERROR(I)=CONFUN(I,1)
        GO TO 1600
C
 1500   ERROR(I)=FUN(I)-CONFUN(I,1)
 1600   CONTINUE
      GO TO 2600
C
C HERE IOPTTH=1 AND A SINGLE CALL TO FNSET WITH INDFN=0 WILL COMPUTE
C CONFUN(.,1) AND (IF ICNUSE=0) ICNTYP(.).
 1700 IF(ICNUSE)1800,1800,1900
C
C HERE IOPTTH=1 AND ICNUSE=0, AND WE SET IPT=0 TO TELL FNSET TO COMPUTE
C ALL CONSTRAINTS (SINCE WE WANT TO BE SURE THAT ALL OF ICNTYP IS
C COMPUTED).  NOTE THAT IF INSTEAD WE HAD IOPTTH=0, THEN IPT WOULD
C BE POSITIVE AT EACH FNSET CALL, TELLING FNSET TO COMPUTE CONSTRAINT
C IPT ONLY.
 1800 IPT=0
      CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,0,
     *ICNTYP,CONFUN)
      GO TO 2000
C
C HERE IOPTTH=1 AND ICNUSE=1, AND IF IPHSE IS NEGATIVE WE SET IPT=-1
C TO TELL FNSET THAT ONLY STANDARD CONSTRAINTS NEED TO BE COMPUTED.
C IF IPHSE=0 HERE WE CHECK TO SEE IF ANY ICNTYP(L) IS POSITIVE FOR
C L=1,...,NUMGR, AND IF SO WE SET IPT=0 TO TELL FNSET TO COMPUTE ALL
C CONSTRAINTS, WHILE OTHERWISE WE SET IPT=-1.
 1900 IF(IPHSE)1940,1920,1920
 1920 DO 1930 L=1,NUMGR
        IF(ICNTYP(L))1930,1930,1960
 1930   CONTINUE
 1940 IPT=-1
      GO TO 1980
 1960 IPT=0
 1980 CALL FNSET(NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,0,
     *IWORK(ILC22),CONFUN)
C
C COMPUTE ERROR AS ABOVE.
 2000 DO 2500 I=1,NUMGR
        IF(ICNTYP(I))2300,2100,2200
C
 2100   ERROR(I)=ZERO
        GO TO 2500
C
 2200   IF(ICNTYP(I)-1)2300,2300,2400
C
 2300   ERROR(I)=CONFUN(I,1)
        GO TO 2500
C
 2400   ERROR(I)=FUN(I)-CONFUN(I,1)
 2500   CONTINUE
C
C
C HAVING FINISHED COMPUTING ERROR(I) AND (IF ICNUSE=0) ICNTYP(I) FOR
C I=1,...,NUMGR WE NOW COMPUTE THE ERROR NORMS.
C WE ALSO COMPUTE THE INDEX IPMAX OF THE CONSTRAINT WHERE THE PRIMARY
C (I.E. TYPE 1 OR TYPE 2) ERROR NORM OCCURS AND THE INDEX ISMAX OF THE
C CONSTRAINT WHERE THE STANDARD (I.E. TYPE -1 OR TYPE -2) ERROR NORM
C OCCURS.
C FIRST INITIALIZE THE INDICATORS AND ERROR NORMS.
 2600 IM1=0
      IM2=0
      IPMAX=0
      ISMAX=0
      ENORM=ZERO
      ENOR2=ZERO
      ENOR3=ZERO
C
      DO 4400 I=1,NUMGR
        EI=ERROR(I)
        IF(ICNTYP(I))3100,4400,2700
C
C HERE ICNTYP(I) .GT. 0.  IF ICNTYP(I)=2 REPLACE EI BY ABS(EI).  IF THIS
C IS THE FIRST I FOUND WITH ICNTYP(I) .GT. 0 WE RESET IPMAX TO I AND PUT
C EI IN ENORM, AND OTHERWISE RESET IPMAX AND PUT EI IN ENORM IF AND ONLY
C IF EI IS BIGGER THAN THE VALUES FOUND SO FAR.
 2700   IF(ICNTYP(I)-1)2770,2770,2730
 2730   EI=ABS(EI)
 2770   IF(IPMAX)2800,2800,2790
 2790   IF(EI-ENORM)4400,4400,2800
 2800   IPMAX=I
        ENORM=EI
        GO TO 4400
 3100   IF(ICNTYP(I)+1)3600,3200,3200
C
C HERE ICNTYP(I)=-1 AND WE DO AS ABOVE EXCEPT WITH IM1 AND ENOR2.
 3200   IF(IM1)3300,3300,3250
 3250   IF(EI-ENOR2)4400,4400,3300
 3300   IM1=I
        ENOR2=EI
        GO TO 4400
C
C HERE ICNTYP(I)=-2 AND WE DO AS ABOVE EXCEPT WITH IM2 AND ENOR3.
 3600   IF(IM2)3700,3700,3650
 3650   IF(EI-ENOR3)4400,4400,3700
 3700   IM2=I
        ENOR3=EI
 4400   CONTINUE
C
C NOW RESET ISMAX IF THERE ARE ANY STANDARD CONSTRAINTS.
      IF(IM1)4500,4500,4700
 4500 IF(IM2)5000,5000,4600
C HERE THERE ARE STANDARD NONLINEAR CONSTRAINTS BUT NO STANDARD LINEAR
C CONSTRAINTS.
 4600 ISMAX=IM2
      GO TO 5000
 4700 IF(IM2)4800,4800,4900
C HERE THERE ARE STANDARD LINEAR CONSTRAINTS BUT NO STANDARD NONLINEAR
C CONSTRAINTS.
 4800 ISMAX=IM1
      GO TO 5000
C HERE THERE ARE BOTH STANDARD LINEAR CONSTRAINTS AND STANDARD NONLINEAR
C CONSTRAINTS.
 4900 IF(ENOR3-ENOR2)4800,4600,4600
C
C SET ERROR(NUMGR+1) THROUGH ERROR(NUMGR+3).
 5000 ERROR(NUMGR+1)=ENORM
      ERROR(NUMGR+2)=ENOR2
      ERROR(NUMGR+3)=ENOR3
      RETURN
      END
      SUBROUTINE RKCON(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *TOLCON,RCHIN,ITER,IRK,ITYP2,ITYP1,ITYPM1,ITYPM2,ICNTYP,PROJCT,
     *RCHDWN,NSTEP,IPHSE,ENCHG,ENC1,PMAT,FUNTBL,IWORK,LIWRK,WORK,
     *LWRK,IACT,ACTDIF,PARPRJ,PARSER,XRK,ERR1,CONFUN,ISUCC,PARAM,
     *ERROR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),ICNTYP(NUMGR),PARAM(NPARM),
     *ERROR(NUMGR+3),PMAT(NPARM+1,NUMGR),FUNTBL(NUMGR,NPARM+1),
     *IWORK(LIWRK),WORK(LWRK),IACT(NUMGR),ACTDIF(NUMGR),
     *PARPRJ(NPARM),PARSER(NPARM),XRK(NPARM+1),ERR1(NUMGR+3),
     *CONFUN(NUMGR,NPARM+1)
C
C SET MACHINE AND PRECISION DEPENDENT PARAMETERS.
      ONE=1.0D0
C     NWRIT=I1MACH(2)
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      QTHI=(ONE+TWO)/FOUR
      QTLO=ONE/FOUR
      TOL1=TEN*TEN*SPCMN
      TOL2=TEN*SPCMN
      IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
      STEPLM=TOLCON/TEN
      ILC06=ILOC(6,NPARM,NUMGR)
      ILC10=ILOC(10,NPARM,NUMGR)
      ILC15=ILOC(15,NPARM,NUMGR)
      ILC21=ILOC(21,NPARM,NUMGR)
      ILC22=ILOC(22,NPARM,NUMGR)
      ILC24=ILOC(24,NPARM,NUMGR)
      ILC27=ILOC(27,NPARM,NUMGR)
      ILC30=ILOC(30,NPARM,NUMGR)
      ILC31=ILOC(31,NPARM,NUMGR)
      ILC33=ILOC(33,NPARM,NUMGR)
      ILC35=ILOC(35,NPARM,NUMGR)
      ILC36=ILOC(36,NPARM,NUMGR)
      ILC37=ILOC(37,NPARM,NUMGR)
      ILC38=ILOC(38,NPARM,NUMGR)
      ILC40=ILOC(40,NPARM,NUMGR)
      ILC43=ILOC(43,NPARM,NUMGR)
      ILC48=ILOC(48,NPARM,NUMGR)
      ISUCC=0
      IWARN=0
      NFAIL=0
      CONUP=ONE
C LIMFL IS A SAFETY VALVE TO CATCH BLUNDERS; WE SET IT HIGH ENOUGH
C THAT IT WILL NOMALLY NOT COME INTO PLAY.
      LIMFL=20
      ENORM=ERROR(NUMGR+1)
      NPAR1=NPARM+1
      PRDEN=SQRT(SQRT(SPCMN))
      PRJBIG=ONE/SPCMN
      IF(ITYP2)20,20,10
   10 PRJBIG=ENORM
C
C THE NEXT GROUP OF STATEMENTS SETS AN INITIAL VALUE FOR PROJCT.
C
   20 IF(ITER)100,100,80
   80 IF(IRK-1)350,350,100
C
C HERE ITER=0, OR ELSE ITER .GT. 0 AND IRK=2, AND WE INITIALIZE PROJCT.
  100 IF(IPHSE+1)110,170,140
C
C HERE ITER=0 OR IRK=2, AND IPHSE=-2, SO WE ARE ATTEMPTING TO GAIN TYPE -2
C FEASIBILITY, AND WE SET THE INITIAL PROJCT TO ENOR3,
C WHICH WILL BE .GT. TOLCON.  NOTE THAT ENOR3 IS NOW IN ERROR(NUMGR+1).
  110 PROJCT=ENORM
      GO TO 170
C
C HERE ITER=0 OR IRK=2, AND IPHSE=0, SO WE ARE IN THE MAIN ITERATIONS,
C AND WE FIRST TRY PROJCT=1.0.
  140 PROJCT=ONE
C
C CHECK TO SEE WHETHER ABS(ENORM) IS VERY
C LARGE RELATIVE TO THE INITIAL PROJCT.  IF ABS(ENORM) .GT.
C PROJCT/PRDEN, WE REPLACE THE INITIAL PROJCT BY PRDEN*ABS(ENORM)
C SO THAT IF WE ARE SUCCESSFUL IN REDUCING ENORM TO ENORM - PROJCT,
C THIS QUANTITY WILL DIFFER FROM ENORM IN AT LEAST SOME SIGNIFICANT
C DIGITS AND THE PROGRAM WILL HAVE A CHANCE TO CONTINUE.
      PE=PRDEN*ABS(ENORM)
      IF(PE-PROJCT)147,147,143
  143 PROJCT=PE
C
C IF ITYP2 .GT. 0 WE REDUCE THE INITIAL PROJCT TO ENORM (IF NECESSARY),
C WHICH WILL BE THE GREATEST DECREASE IN ENORM WE CAN HOPE FOR SINCE
C THERE WILL BE TYPE 2 CONSTRAINTS.
  147 IF(ITYP2)170,170,150
  150 IF(ENORM-PROJCT)160,170,170
  160 PROJCT=ENORM
C
C WE DO NOT WISH FOR PROJCT TO BE SET BELOW 100.0*SPCMN
  170 IF(PROJCT-TEN*TEN*SPCMN)180,800,800
  180 PROJCT=TEN*TEN*SPCMN
      GO TO 800
C
C HERE ITER .GT. 0 AND IRK=1, AND WE BUILD ON THE PREVIOUS SUCCESSFUL
C RK ITERATION, WHICH REDUCED THE ERROR NORM.  COMPUTE THE RATIO QT,
C WHICH WOULD BE 1.0 IF RUNGE-KUTTA WERE EXACT AND NO CORRECTION STEP
C WERE NEEDED.
  350 QT=-ENC1/PROJCT
C
      IF(QT-QTHI)500,400,400
C
C HERE QT .GE. QTHI, SO WE INCREASE PROJCT BY A FACTOR OF 2.0.
  400 PROJCT=TWO*PROJCT
      GO TO 800
C
C IF QTLO .LT. QT .LT. QTHI WE LEAVE PROJCT THE SAME, WHILE IF QT .LE.
C QTLO WE DIVIDE PROJCT BY 4.0.
  500 IF(QT-QTLO)600,600,800
  600 PROJCT=PROJCT/FOUR
C
C WE DO NOT WANT PROJCT TO BE BIGGER THAN PRJBIG OR SMALLER THAN
C STEPLM.
  800 IF(PROJCT-PRJBIG)1000,1000,900
  900 PROJCT=PRJBIG
 1000 IF(PROJCT-STEPLM)1100,1200,1200
 1100 IWARN=1
      PROJCT=STEPLM
C
C CALL RKSACT TO PUT THE (SIGNED) INDICES OF THE ACTIVE CONSTRAINTS IN
C IACT AND THEIR NUMBER IN MACTRK.
 1200 CALL RKSACT(IOPTN,NUMGR,ICNTYP,RCHDWN,RCHIN,CONUP,PROJCT,ERROR,
     *MACTRK,ACTDIF,IACT)
C
C SET UNIT FOR USE IN RCHMOD.  UNIT WILL BE THE VALUE OF PROJCT WHEN
C RKSACT WAS LAST CALLED.
      UNIT=PROJCT
C
C CALL PMTST TO SET UP PMAT.
      CALL PMTST(IOPTN,NUMGR,NPARM,PARAM,ICNTYP,MACTRK,IACT,PTTBL,
     *IPTB,INDM,ACTDIF,IPHSE,IWORK,LIWRK,WORK,LWRK,CONFUN,PMAT)
C
C COPY PMAT TRANSPOSE INTO FUNTBL FOR POSSIBLE LATER USE.
      DO 1400 J=1,NPAR1
        DO 1300 I=1,MACTRK
          FUNTBL(I,J)=PMAT(J,I)
 1300     CONTINUE
 1400   CONTINUE
C
C
C STATEMENTS ABOVE THIS POINT WILL NOT BE EXECUTED AGAIN IN THIS CALL
C TO RKCON.
C
C INCREMENT NFAIL, WHICH COUNTS THE NUMBER OF WOLFE CALLS IN THIS CALL TO
C RKCON.
 2700 NFAIL=NFAIL+1
C
C CALL WOLFE WITH ISTRT=0 TO SOLVE THE LEAST DISTANCE QP PROBLEM FROM
C SCRATCH.
      CALL WOLFE(NPARM,MACTRK,PMAT,0,S,NCOR,IWORK(ILC15),IWORK,
     *LIWRK,WORK,LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),
     *NPARM,NUMGR,WORK(ILC40),WORK(ILC36),WDIST,NMAJ,NMIN,JFLAG)
C
C IF WOLFE FAILS, WE MAY TRY AGAIN WITH A SMALLER PROJCT.
C
      IF(JFLAG)5000,5000,2800
C
C THE NEXT GROUP OF STATEMENTS IS TO REDUCE PROJCT (IF POSSIBLE) IN CASE
C OF A FAILURE OF SOME KIND.
C
 2800 IF(NFAIL-LIMFL)3000,2900,2900
C
C HERE RKCON COULD NOT REDUCE THE ERROR NORM AND WE RETURN WITH THE
C WARNING ISUCC=1.
 2900 ISUCC=1
      RETURN
C
C PREPARE TO TRY ANOTHER ITERATION IN RKCON BY
C REDUCING PROJCT, AND MAKING SURE PROJCT IS NOT TOO SMALL.
 3000 PROJCT=PROJCT/(FOUR+FOUR)
      IF(PROJCT-STEPLM)3100,3300,3300
 3100 IF(IWARN)3200,3200,2900
 3200 IWARN=1
      PROJCT=STEPLM
C
C NOW RESET ACTDIF FOR THIS PROJCT.
 3300 DO 4100 L=1,MACTRK
        I=IABS(IACT(L))
        IF(ICNTYP(I))3700,3350,3400
C
C ICNTYP(I)=0 SHOULD NOT OCCUR HERE SINCE CONSTRAINT I WAS DECLARED
C TO BE ACTIVE IN RKSACT, BUT WE ACCOUNT FOR IT ANYWAY AS A PRECAUTION.
 3350   ACTDIF(I)=ZERO
        GO TO 4100
C
 3400   IF(ICNTYP(I)-1)3500,3500,3600
C
C HERE WE HAVE AN ACTIVE TYPE 1 CONSTRAINT.
 3500   ACTDIF(L)=ONE+(ERROR(I)-ENORM)/PROJCT
        GO TO 4100
C
C HERE WE HAVE AN ACTIVE TYPE 2 CONSTRAINT.
 3600   ACTDIF(L)=ONE+(ABS(ERROR(I))-ENORM)/PROJCT
        GO TO 4100
C
 3700   IF(ICNTYP(I)+1)3900,3800,3800
C
C HERE WE HAVE AN ACTIVE TYPE -1 CONSTRAINT.
 3800   ACTDIF(L)=ERROR(I)/PROJCT
        GO TO 4100
C
C HERE WE HAVE AN ACTIVE TYPE -2 CONSTRAINT, AND WE SET ACTDIF(L)=
C MIN (CONUP, ERROR(I)/PROJCT).
 3900   ACTDIF(L)=ERROR(I)/PROJCT
        IF(ACTDIF(L)-CONUP)4100,4100,4000
 4000   ACTDIF(L)=CONUP
 4100   CONTINUE
C
C COPY THE FIRST NPARM ROWS OF PMAT FROM OLD PMAT TRANSPOSE STORED
C IN FUNTBL, THEN APPEND ACTDIF AS THE LAST ROW.
      DO 4400 J=1,MACTRK
        DO 4300 I=1,NPARM
          PMAT(I,J)=FUNTBL(J,I)
 4300     CONTINUE
        PMAT(NPAR1,J)=ACTDIF(J)
 4400   CONTINUE
      GO TO 2700
C
C END OF GROUP OF STATEMENTS TO REDUCE PROJCT (IF POSSIBLE) TO HANDLE
C A FAILURE OF SOME KIND.
C
C DO AN RK STEP.
 5000 CALL RKPAR(IOPTN,NUMGR,NPARM,ICNTYP,MACTRK,IACT,ACTDIF,PROJCT,
     *PARAM,FUN,IFUN,PTTBL,IPTB,INDM,WORK(ILC36),PMAT,NCOR,
     *S,ITYPM1,ITYPM2,UNIT,TOLCON,RCHIN,NSTEP,ERROR,
     *IPHSE,IWORK,LIWRK,WORK,LWRK,CONFUN,WORK(ILC37),WORK(ILC38),
     *WORK(ILC43),PARPRJ,IFRKPR)
      IF(IFRKPR)5100,5100,2800
C
C HERE RKPAR SUCCEEDED.  IF THERE ARE ANY STANDARD CONSTRAINTS WE CALL
C CORRCT TO MOVE BACK INTO THE FEASIBLE REGION IF NECESSARY.
 5100 IF(ITYPM1+ITYPM2)5300,5300,5200
 5200 CALL CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *ICNTYP,UNIT,TOLCON,RCHIN,ERROR,MACTRK,IACT,PROJCT,IPHSE,
     *IWORK,LIWRK,WORK,LWRK,WORK(ILC27),ERR1,WORK(ILC10),
     *PMAT,CONFUN,WORK(ILC48),IWORK(ILC21),PARPRJ,ICORCT)
      IF(ICORCT)5300,5300,2800
C
C PUT THE SEARCH DIRECTION VECTOR PARPRJ - PARAM INTO XRK.
 5300 DO 5320 J=1,NPARM
        XRK(J)=PARPRJ(J)-PARAM(J)
 5320   CONTINUE
C
C CALL SEARSL TO DO A LINE SEARCH IN DIRECTION XRK AND PUT THE RESULTING
C VECTOR IN PARSER.  START WITH A PROJECTION FACTOR PROSEA=1.0.
C PARPRJ WILL BE USED TEMPORARILY AS A WORK VECTOR IN SEARSL.
      PROSEA=ONE
C
C WE NOW WISH TO DETERMINE PRJLIM = THE SMALLER OF 1.0/SPCMN AND
C THE LARGEST VALUE OF PROSEA FOR WHICH THE LINEAR STANDARD CONSTRAINTS
C ARE SATISFIED FOR THE PARAMETER VECTOR PARAM+PROSEA*XRK.  THIS
C WILL GIVE AN UPPER BOUND FOR LINE SEARCHING.  NOTE THAT IN
C THEORY WE SHOULD HAVE PRJLIM .GE. 1.0 SINCE THE LINEAR STANDARD
C CONSTRAINTS SHOULD BE SATISFIED FOR PROSEA=0.0 AND PROSEA=1.0, BUT
C ROUNDOFF ERROR COULD AFFECT THIS A LITTLE.  IF THERE ARE NO
C LINEAR STANDARD CONSTRAINTS, WE SET PRJLIM=1.0/SPCMN.
      PRJLIM=ONE/SPCMN
C*****INSERT TO MAKE SEARCHING LESS VIOLENT.
C     PRJLIM=TWO
C*****END INSERT
      IF(ITYPM1)5380,5380,5325
C HERE WE HAVE AT LEAST ONE TYPE -1 CONSTRAINT, AND IF IOPTTH=1 WE
C CALL DERST TO PUT ALL THE STANDARD CONSTRAINT VALUES AND GRADIENTS
C INTO CONFUN(.,.).
 5325 IF(IOPTTH)5340,5340,5330
C WE SET IPT=-1 TO TELL DERST TO COMPUTE STANDARD CONSTRAINTS ONLY.
 5330 IPT=-1
      CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *WORK(ILC24),WORK(ILC35),IWORK(ILC22),CONFUN)
 5340 DO 5375 I=1,NUMGR
        IF(ICNTYP(I)+1)5375,5345,5375
 5345   IPT=I
C HERE WE HAVE A TYPE -1 CONSTRAINT AND IF IOPTTH=0 WE CALL DERST
C TO PUT THE CONSTRAINT VALUE AND GRADIENT INTO CONFUN(IPT,.).
        IF(IOPTTH)5350,5350,5355
 5350   CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *  WORK(ILC24),WORK(ILC35),IWORK(ILC22),CONFUN)
C
C WE WISH TO HAVE SUMMATION (CONFUN(IPT,J+1)*(PARAM(J)+PROSEA*XRK(J)))
C + C(IPT) .LE. 0.0 FOR IPT=1,...,NUMGR, ICNTYP(IPT) = -1,
C WHERE THE IPTTH CONSTRAINT APPLIED TO PARAM SAYS
C SUMMATION (CONFUN(IPT,J+1)*PARAM(J)) + C(IPT) .LE. 0.0, SO C(IPT) IS
C THE CONSTANT TERM IN THE LEFT SIDE OF LINEAR CONSTRAINT IPT.
C THUS FOR I=1PT,...,NUMGR, ICNTYP(IPT) = -1, WE WANT PRJLIM*SS .LE.
C SSS, WHERE SS = SUMMATION (CONFUN(IPT,J+1)*XRK(J)) AND SSS = -C(IPT) -
C SUMMATION (CONFUN(IPT,J+1)*PARAM(J)) = -CONFUN(IPT,1).
 5355   SS=ZERO
        DO 5360 J=1,NPARM
          SS=SS+CONFUN(I,J+1)*XRK(J)
 5360     CONTINUE
C IF SS .LT. 10.0*SPCMN THIS CONSTRAINT WILL NOT PUT A SIGNIFICANT
C RESTRICTION ON PROSEA.
        IF(SS-TOL2)5375,5365,5365
C HERE SS .GE. 10.0*SPCMN AND WE COMPARE SSS/SS AGIANST PRJLIM.
 5365   QUOTS=-CONFUN(I,1)/SS
        IF(PRJLIM-QUOTS)5375,5375,5370
 5370   PRJLIM=QUOTS
 5375   CONTINUE
C
 5380 CALL SEARSL(IOPTN,NUMGR,NPARM,PRJLIM,TOL1,XRK,FUN,IFUN,
     *PTTBL,IPTB,INDM,PARAM,ERROR,RCHDWN,MACTRK,IACT,IPHSE,
     *UNIT,TOLCON,RCHIN,ITYPM1,ITYPM2,IWORK,LIWRK,WORK,LWRK,ERR1,
     *PARPRJ,PROSEA,EMIN,EMIN1,PARSER,NSRCH)
C
C COMPUTE THE PRINCIPAL ERROR NORM CHANGE ENCHG.  ALSO COMPUTE ENC1, THE
C CHANGE IN THE PRINCIPAL ERROR NORM WITHOUT THE LINE SEARCH.
      ENCHG=EMIN-ENORM
      ENC1=EMIN1-ENORM
C
C IF WE OBTAINED MORE THAN A TOL1 REDUCTION IN ENORM WE UPDATE
C PARAM AND CALL ERCMP1 TO UPDATE ERROR, AND RETURN WITH ISUCC=0
C INDICATING SUCCESS.
C OTHERWISE WE CHECK TO SEE IF WE HAVE REACHED THE RKCON ITERATION
C LIMIT, AND IF SO WE RETURN WITH ISUCC=1, INDICATING FAILURE.
      IF(ENCHG+TOL1)5500,2800,2800
C
 5500 DO 5600 J=1,NPARM
        PARAM(J)=PARSER(J)
 5600   CONTINUE
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARAM,1,IPHSE,IWORK,LIWRK,CONFUN,ICNTYP,IPMAX,
     *ISMAX,ERROR)
      RETURN
      END
      SUBROUTINE RKSACT(IOPTN,NUMGR,ICNTYP,RCHDWN,RCHIN,CONUP,
     *PROJCT,ERROR,MACTRK,ACTDIF,IACT)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION ERROR(NUMGR+3),IACT(NUMGR),ACTDIF(NUMGR),
     *ICNTYP(NUMGR)
C
C THIS SUBROUTINE PUTS THE (SIGNED) INDICES OF THE MACTRK
C ACTIVE CONSTRAINTS IN IACT.  IT ALSO SETS THE RIGHT SIDE VECTOR
C ACTDIF FOR THE WOLFE SUBPROBLEM.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR RKSACT.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      TWO=ONE+ONE
      ENORM=ERROR(NUMGR+1)
      ELOW=ENORM-RCHDWN*PROJCT
      RCHIND=RCHIN*PROJCT
C
C DETERMINE THE NUMBER MACTRK OF ACTIVE CONSTRAINTS, THEIR INDICATOR
C IACT, AND THE VECTOR ACTDIF OF RIGHT SIDES FOR THE WOLFE SUBPROBLEM.
      L=0
      DO 1200 I=1,NUMGR
        IF(ICNTYP(I))700,1200,100
  100   IF(ICNTYP(I)-1)200,200,400
C
C HERE WE HAVE A TYPE 1 CONSTRAINT, OR A TYPE 2 CONSTRAINT WITH
C ERROR(I) .GE. 0.0.
  200   IF(ERROR(I)-ELOW)1200,300,300
C
C HERE WE HAVE AN ACTIVE TYPE 1 CONSTRAINT OR A +ACTIVE TYPE 2 CONSTRAINT.
  300   L=L+1
        IACT(L)=I
        ACTDIF(L)=ONE+(ERROR(I)-ENORM)/PROJCT
        GO TO 1200
C
C HERE WE HAVE A TYPE 2 CONSTRAINT.
  400   IF(ERROR(I))500,200,200
  500   IF(-ERROR(I)-ELOW)1200,600,600
C
C HERE WE HAVE A -ACTIVE TYPE 2 CONSTRAINT.
  600   L=L+1
        IACT(L)=-I
        ACTDIF(L)=ONE+(-ERROR(I)-ENORM)/PROJCT
        GO TO 1200
C
  700   IF(ICNTYP(I)+1)900,800,800
C
C HERE WE HAVE A TYPE -1 CONSTRAINT, WHICH WILL AUTOMATICALLY BE
C DECLARED TO BE ACTIVE.
  800   L=L+1
        IACT(L)=I
        ACTDIF(L)=ERROR(I)/PROJCT
        GO TO 1200
C
C HERE WE HAVE A TYPE -2 CONSTRAINT, WHICH WILL BE DECLARED TO BE
C ACTIVE IFF ERROR(I) .GE. -RCHIND.
  900   IF(ERROR(I)+RCHIND)1200,1000,1000
C
C HERE WE HAVE AN ACTIVE TYPE -2 CONSTRAINT, AND WE SET ACTDIF(L)=
C MIN (CONUP, ERROR(I)/PROJCT).
 1000   L=L+1
        IACT(L)=I
        ACTDIF(L)=ERROR(I)/PROJCT
        IF(ACTDIF(L)-CONUP)1200,1200,1100
 1100   ACTDIF(L)=CONUP
 1200   CONTINUE
      MACTRK=L
      RETURN
      END
      SUBROUTINE PMTST(IOPTN,NUMGR,NPARM,PARAM,ICNTYP,MACTRK,
     *IACT,PTTBL,IPTB,INDM,ACTDIF,IPHSE,IWORK,LIWRK,
     *WORK,LWRK,CONFUN,PMAT)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PARAM(NPARM),IACT(NUMGR),PTTBL(IPTB,INDM),
     *ICNTYP(NUMGR),CONFUN(NUMGR,NPARM+1),ACTDIF(NUMGR),
     *PMAT(NPARM+1,NUMGR),IWORK(LIWRK),WORK(LWRK)
C
C THIS SUBROUTINE SETS UP THE (NPARM+1) BY MACTRK MATRIX PMAT.
C FOR 1 .LE. J .LE. MACTRK, THE TOP NPARM ELEMENTS OF COLUMN J OF PMAT
C WILL CONTAIN THE NEGATIVE OF THE GRADIENT OF ACTIVE CONSTRAINT J (IF
C CONSTRAINT J IS OF TYPE 2, I.E. OF THE FORM ABS(F(X) - F(PARWRK,X))
C .LE. W, THE LEFT SIDE WILL BE TREATED AS F(X) - F(PARWRK,X) IF THIS
C QUANTITY IS NONNEGATIVE AND WILL BE TREATED AS F(PARWRK,X) - F(X)
C OTHERWISE). THE (NPARM+1)ST ROW OF PMAT WILL CONTAIN ACTDIF, THE
C RIGHT SIDE OF THE INEQUALITIES GRADIENT.VECTOR .GE. ACTDIF.
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR PMTST.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      ILC22=ILOC(22,NPARM,NUMGR)
      ILC24=ILOC(24,NPARM,NUMGR)
      ILC35=ILOC(35,NPARM,NUMGR)
      IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
      NPAR1=NPARM+1
C
      IF(IOPTTH)138,138,121
C
C HERE IOPTTH=1 AND WE CALL DERST TO PUT GRADIENT VALUES INTO CONFUN.
C IF IPHSE .LT. 0 OR NO ICNTYP(L) IS POSITIVE, SET IPT=-1 TO TELL DERST
C TO COMPUTE STANDARD CONSTRAINTS ONLY, WHILE OTHERWISE SET IPT=0 TO
C TELL DERST TO COMPUTE ALL CONSTRAINTS.
  121 IF(IPHSE)130,124,124
  124 DO 127 L=1,NUMGR
        IF(ICNTYP(L))127,127,133
  127   CONTINUE
  130 IPT=-1
      GO TO 136
  133 IPT=0
  136 CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *WORK(ILC24),WORK(ILC35),IWORK(ILC22),CONFUN)
C
  138 DO 800 I=1,MACTRK
        II=IACT(I)
        IPT=IABS(II)
        IF(IOPTTH)140,140,210
C
C HERE IOPTTH=0 AND WE HAVE NOT YET PLACED THE GRADIENT IN CONFUN, SO WE
C CALL DERST TO DO SO NOW.  DERST WILL ALSO COMPUTE THE
C CONSTRAINT VALUES, WHICH WILL NOT BE NEEDED HERE, BUT EXPECTING USERS TO
C WRITE FNSET SO THAT GRADIENT CALCULATIONS WILL NOT NEED FUNCTION VALUE
C CALCULATION RESULTS WOULD BE TOO MUCH OF A PROGRAMMING TRAP.
  140   CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARAM,IPT,
     *  WORK(ILC24),WORK(ILC35),IWORK(ILC22),CONFUN)
C
C NOW THE GRADIENT FOR CONSTRAINT IPT IS IN CONFUN(IPT,.), AND WE PUT IT
C OR ITS NEGATIVE INTO PMAT.
C IF ICNTYP(IPT) .LE. 1 WE PROCEED AS IF WE HAD A -ACTIVE CONSTRAINT IN
C THE ICNTYP(IPT)=2 CASE.  IN ALL CASES WE PUT THE NEGATIVE OF THE
C CONSTRAINT GRADIENT INTO COLUMN I OF PMAT.
  210   IF(ICNTYP(IPT)-1)675,675,220
C
C HERE ICNTYP(IPT)=2.
  220   IF(II)675,675,300
C
C HERE WE HAVE A +ACTIVE CONSTRAINT AT POINT IPT.
C THE CONSTRAINT GRADIENT IS IN -CONFUN(IPT,.) SINCE THE LEFT SIDE OF
C CONSTRAINT I IS F(X)-F(PARWRK,X) AND DERST COMPUTES THE
C GRADIENT OF F(PARWRK,X).  THUS WE PUT CONFUN(IPT,.) IN COLUMN I OF PMAT.
  300   DO 400 J=1,NPARM
          PMAT(J,I)=CONFUN(IPT,J+1)
  400     CONTINUE
        GO TO 800
C
C HERE WE HAVE A -ACTIVE TYPE 2 CONSTRAINT AT POINT -II OR AN ACTIVE
C CONSTRAINT OF TYPE -2, -1, OR 1 AT POINT II.
  675   DO 700 J=1,NPARM
          PMAT(J,I)=-CONFUN(IPT,J+1)
  700     CONTINUE
  800   CONTINUE
C
C PUT ACTDIF IN THE LAST ROW OF PMAT.
      DO 2300 I=1,MACTRK
        PMAT(NPAR1,I)=ACTDIF(I)
 2300   CONTINUE
      RETURN
      END
      SUBROUTINE RKPAR(IOPTN,NUMGR,NPARM,ICNTYP,MACTRK,IACT,ACTDIF,
     *PROJCT,PARAM,FUN,IFUN,PTTBL,IPTB,INDM,VDER,PMAT,NCOR,S,
     *ITYPM1,ITYPM2,UNIT,TOLCON,RCHIN,NSTEP,ERROR,IPHSE,IWORK,LIWRK,
     *WORK,LWRK,CONFUN,VDERN,VDERS,WVEC,PARPRJ,IFRKPR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PARAM(NPARM),FUN(IFUN),PTTBL(IPTB,INDM),VDER(NPARM),
     *PARPRJ(NPARM),VDERS(NPARM),WVEC(NPARM),VDERN(NPARM),
     *ICNTYP(NUMGR),ERROR(NUMGR+3),IACT(NUMGR),ACTDIF(NUMGR),
     *CONFUN(NUMGR,NPARM+1),PMAT(NPARM+1,NUMGR),IWORK(LIWRK),
     *WORK(LWRK)
C
C THIS SUBROUTINE COMPUTES A PARAMETER VECTOR PARPRJ USING FOURTH
C ORDER RUNGE KUTTA WITH H=-PROJCT.  H IS NEGATIVE SINCE WE WANT
C TO APPROXIMATE THE PARAMETERS RESULTING FROM DECREASING W BY
C ABS(H).  IF WE DO NSTEP STEPS THEN H=-PROJCT/NSTEP.
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR RKPAR.
      ONE=1.0D0
      TWO=ONE+ONE
C     NWRIT=I1MACH(2)
      ILC06=ILOC(6,NPARM,NUMGR)
      ILC10=ILOC(10,NPARM,NUMGR)
      ILC11=ILOC(11,NPARM,NUMGR)
      ILC15=ILOC(15,NPARM,NUMGR)
      ILC21=ILOC(21,NPARM,NUMGR)
      ILC27=ILOC(27,NPARM,NUMGR)
      ILC30=ILOC(30,NPARM,NUMGR)
      ILC31=ILOC(31,NPARM,NUMGR)
      ILC33=ILOC(33,NPARM,NUMGR)
      ILC40=ILOC(40,NPARM,NUMGR)
      ILC48=ILOC(48,NPARM,NUMGR)
C IFRKPR=0 IS A SIGNAL THAT THE SUBROUTINE OPERATED NORMALLY.
      IFRKPR=0
      PROJ1=PROJCT/NSTEP
      P6=PROJ1/(TWO+TWO+TWO)
      NPAR1=NPARM+1
      NSTCNT=1
C PARPRJ WILL BE USED AS THE BASE POINT FOR THE NEXT RK STEP DURING THE
C OPERATION OF THIS SUBROUTINE.
   10 DO 20 J=1,NPARM
        PARPRJ(J)=PARAM(J)
        VDERN(J)=VDER(J)
   20   CONTINUE
C
C NOTE THAT HERE H*VDERN IS THE K1 OF THE USUAL RUNGE-KUTTA FORMULAE.
C SET THE WORK VECTOR WVEC = PARPRJ-PROJ1*VDERN/2.0, THEN CALL PMTST
C AND WOLFE TO GET THE VECTOR (AGAIN CALLED VDERN) OF DERIVATIVE VALUES.
C THEN H*VDERN WILL BE THE K2 OF THE USUAL RUNGE-KUTTA FORMULAE.
C WE WILL ACCUMULATE K1/H + 2.0*K2/H + 2.0*K3/H IN VDERS, AND ADD IN
C K4/H AT THE END.
   80 DO 100 J=1,NPARM
        VDERS(J)=VDERN(J)
        WVEC(J)=PARPRJ(J)-PROJ1*VDERN(J)/TWO
  100   CONTINUE
C IF THERE ARE ANY STANDARD CONSTRAINTS, WE CORRECT BACK INTO THE
C FEASIBLE REGION IF POSSIBLE BEFORE CALLING PMTST.
      IF(ITYPM1+ITYPM2)108,108,102
  102 CALL CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,ICNTYP,
     *UNIT,TOLCON,RCHIN,ERROR,MACTRK,IACT,PROJCT,
     *IPHSE,IWORK,LIWRK,WORK,LWRK,WORK(ILC27),WORK(ILC11),
     *WORK(ILC10),PMAT,CONFUN,WORK(ILC48),IWORK(ILC21),WVEC,ICORCT)
      IF(ICORCT)108,108,200
  108 CALL PMTST(IOPTN,NUMGR,NPARM,WVEC,ICNTYP,MACTRK,
     *IACT,PTTBL,IPTB,INDM,ACTDIF,IPHSE,IWORK,
     *LIWRK,WORK,LWRK,CONFUN,PMAT)
      CALL WOLFE(NPARM,MACTRK,PMAT,1,S,NCOR,IWORK(ILC15),IWORK,
     *LIWRK,WORK,LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),
     *NPARM,NUMGR,WORK(ILC40),VDERN,WDIST,NMAJ,NMIN,JFLAG)
C IF WOLFE FAILED, SO WILL THIS SUBROUTINE.
      IF(JFLAG)300,300,200
C
  200 IFRKPR=1
C     WRITE(NWRIT,250)
C 250 FORMAT(22H *****RKPAR HAS FAILED)
      RETURN
C
C NOW VDERN REPRESENTS K2/H.  SET WVEC = PARPRJ-PROJ1*VDERN/2.0 AND
C COMPUTE THE NEW VDERN, WHICH WILL REPRESENT K3/H.
  300 DO 400 J=1,NPARM
        VDERS(J)=VDERS(J)+TWO*VDERN(J)
        WVEC(J)=PARPRJ(J)-PROJ1*VDERN(J)/TWO
  400   CONTINUE
C IF THERE ARE ANY STANDARD CONSTRAINTS, WE CORRECT BACK INTO THE
C FEASIBLE REGION IF POSSIBLE BEFORE CALLING PMTST.
      IF(ITYPM1+ITYPM2)408,408,402
  402 CALL CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,ICNTYP,
     *UNIT,TOLCON,RCHIN,ERROR,MACTRK,IACT,PROJCT,
     *IPHSE,IWORK,LIWRK,WORK,LWRK,WORK(ILC27),WORK(ILC11),
     *WORK(ILC10),PMAT,CONFUN,WORK(ILC48),IWORK(ILC21),WVEC,ICORCT)
      IF(ICORCT)408,408,200
  408 CALL PMTST(IOPTN,NUMGR,NPARM,WVEC,ICNTYP,MACTRK,
     *IACT,PTTBL,IPTB,INDM,ACTDIF,IPHSE,IWORK,
     *LIWRK,WORK,LWRK,CONFUN,PMAT)
      CALL WOLFE(NPARM,MACTRK,PMAT,1,S,NCOR,IWORK(ILC15),IWORK,
     *LIWRK,WORK,LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),
     *NPARM,NUMGR,WORK(ILC40),VDERN,WDIST,NMAJ,NMIN,JFLAG)
      IF(JFLAG)500,500,200
C
C NOW VDERN REPRESENTS K3/H.  SET WVEC = PARPRJ-PROJ1*VDERN AND
C COMPUTE THE NEW VDERN, WHICH WILL REPRESENT K4/H.
  500 DO 600 J=1,NPARM
        VDERS(J)=VDERS(J)+TWO*VDERN(J)
        WVEC(J)=PARPRJ(J)-PROJ1*VDERN(J)
  600   CONTINUE
C IF THERE ARE ANY STANDARD CONSTRAINTS, WE CORRECT BACK INTO THE
C FEASIBLE REGION IF POSSIBLE BEFORE CALLING PMTST.
      IF(ITYPM1+ITYPM2)608,608,602
  602 CALL CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,ICNTYP,
     *UNIT,TOLCON,RCHIN,ERROR,MACTRK,IACT,PROJCT,
     *IPHSE,IWORK,LIWRK,WORK,LWRK,WORK(ILC27),WORK(ILC11),
     *WORK(ILC10),PMAT,CONFUN,WORK(ILC48),IWORK(ILC21),WVEC,ICORCT)
      IF(ICORCT)608,608,200
  608 CALL PMTST(IOPTN,NUMGR,NPARM,WVEC,ICNTYP,MACTRK,
     *IACT,PTTBL,IPTB,INDM,ACTDIF,IPHSE,IWORK,
     *LIWRK,WORK,LWRK,CONFUN,PMAT)
      CALL WOLFE(NPARM,MACTRK,PMAT,1,S,NCOR,IWORK(ILC15),IWORK,
     *LIWRK,WORK,LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),
     *NPARM,NUMGR,WORK(ILC40),VDERN,WDIST,NMAJ,NMIN,JFLAG)
      IF(JFLAG)700,700,200
C
C NOW VDERN REPRESENTS K4/H, SO VDERS + VDERN WILL REPRESENT (K1 +
C 2.0*K2 + 2.0*K3 + K4)/H.  PUT THE NEW PARAMETER VECTOR IN PARPRJ.
  700 DO 800 J=1,NPARM
        PARPRJ(J)=PARPRJ(J)-P6*(VDERS(J)+VDERN(J))
  800   CONTINUE
      IF(NSTCNT-NSTEP)820,810,810
  810 RETURN
C
C HERE NSTCNT .LT. NSTEP AND WE SET UP FOR THE NEXT RK STEP.
C AFTER WE HAVE DONE THIS STEP, VDERN WILL REPRESENT THE VDER1 FOR THE
C NEXT STEP.  PARPRJ ALREADY IS THE BASE POINT FOR THE NEXT STEP.
  820 NSTCNT=NSTCNT+1
C IF THERE ARE ANY STANDARD CONSTRAINTS, WE CORRECT BACK INTO THE
C FEASIBLE REGION IF POSSIBLE BEFORE CALLING PMTST.
      IF(ITYPM1+ITYPM2)848,848,842
  842 CALL CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,ICNTYP,
     *UNIT,TOLCON,RCHIN,ERROR,MACTRK,IACT,PROJCT,
     *IPHSE,IWORK,LIWRK,WORK,LWRK,WORK(ILC27),WORK(ILC11),
     *WORK(ILC10),PMAT,CONFUN,WORK(ILC48),IWORK(ILC21),PARPRJ,ICORCT)
      IF(ICORCT)848,848,200
  848 CALL PMTST(IOPTN,NUMGR,NPARM,PARPRJ,ICNTYP,MACTRK,
     *IACT,PTTBL,IPTB,INDM,ACTDIF,IPHSE,IWORK,
     *LIWRK,WORK,LWRK,CONFUN,PMAT)
      CALL WOLFE(NPARM,MACTRK,PMAT,1,S,NCOR,IWORK(ILC15),IWORK,
     *LIWRK,WORK,LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),
     *NPARM,NUMGR,WORK(ILC40),VDERN,WDIST,NMAJ,NMIN,JFLAG)
      IF(JFLAG)80,80,200
      END
      SUBROUTINE CORRCT(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,
     *INDM,ICNTYP,UNIT,TOLCON,RCHIN,ERROR,MACT,IACT,PROJCT,
     *IPHSE,IWORK,LIWRK,WORK,LWRK,PARWRK,ERR1,DVEC,PMAT,CONFUN,ZWORK,
     *JCNTYP,PARPRJ,ICORCT)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),ICNTYP(NUMGR),
     *PARPRJ(NPARM),PARWRK(NPARM),ERR1(NUMGR+3),DVEC(NPARM),
     *PMAT(NPARM+1,NUMGR),JCNTYP(NUMGR),CONFUN(NUMGR,NPARM+1),
     *ZWORK(NPARM),ERROR(NUMGR+3),IACT(NUMGR),IWORK(LIWRK),WORK(LWRK)
C
C THIS SUBROUTINE DETERMINES WHETHER PARPRJ VIOLATES ANY TYPE -2
C OR TYPE -1 (I.E. STANDARD) CONSTRAINTS BY MORE THAN TOLCON, AND IF
C SO IT ATTEMPTS TO CORRECT BACK TO THE FEASIBLE REGION.  IF IT IS
C SUCCESSFUL IT SETS ICORCT=0 AND REPLACES PARPRJ BY THE CORRECTED
C VECTOR.  IF IT IS NOT SUCCESSFUL IT SETS ICORCT=1 AND LEAVES PARPRJ
C UNCHANGED.  IF NO CORRECTION WAS NEEDED IT SETS ICORCT=-1 AND LEAVES
C PARPRJ UNCHANGED.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      ILC06=ILOC(6,NPARM,NUMGR)
      ILC16=ILOC(16,NPARM,NUMGR)
      ILC22=ILOC(22,NPARM,NUMGR)
      ILC24=ILOC(24,NPARM,NUMGR)
      ILC30=ILOC(30,NPARM,NUMGR)
      ILC31=ILOC(31,NPARM,NUMGR)
      ILC33=ILOC(33,NPARM,NUMGR)
      ILC35=ILOC(35,NPARM,NUMGR)
      ILC41=ILOC(41,NPARM,NUMGR)
      IOPTTH=(IOPTN-(IOPTN/100000)*100000)/10000
      NPAR1=NPARM+1
      NEWTIT=0
C SET THE LIMIT NEWTLM ON THE NUMBER OF QUASI-NEWTON STEPS (I.E. CALLS
C TO SEARCR), AND IF NEWTLM .GT. 1 SET THE PARAMETER GAIN SUCH THAT NO
C FURTHER NEWTON STEPS WILL BE TRIED UNLESS THE LAST STEP REDUCED THE
C MAXIMUM STANDARD ERROR BY A FACTOR OF GAIN OR BETTER.
      NEWTLM=3
      GAIN=ONE/(TEN*TEN)
C FOR NOW, SET JCNTYP(I)=0 IF ICNTYP(I) .GT. 0 AND SET JCNTYP(I)
C =ICNTYP(I) OTHERWISE TO DIRECT ERCMP1 TO COMPUTE THE ERRORS FOR THE
C STANDARD CONSTRAINTS ONLY.
      DO 300 I=1,NUMGR
        IF(ICNTYP(I))200,200,100
  100   JCNTYP(I)=0
        GO TO 300
  200   JCNTYP(I)=ICNTYP(I)
  300   CONTINUE
C PUT PARPRJ IN PARWRK FOR USE IN ERCMP1 AND FNSET.
      DO 400 J=1,NPARM
        PARWRK(J)=PARPRJ(J)
  400   CONTINUE
C CALL ERCMP1 WITH ICNUSE=1 TO COMPUTE THE STANDARD ERRORS.
C WE TAKE IPHSE=-3 AS A KLUDGE TO TELL ERCMP1 TO COMPUTE ONLY STANDARD
C ERRORS IF THE TEN THOUSANDS DIGIT OF IOPTN IS 1, THUS SAVING ERCMP1
C THE WORK OF SCANNING ICNTYP.
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARWRK,1,-3,IWORK,LIWRK,CONFUN,JCNTYP,IPMAX,ISMAX,ERR1)
C
C IF THE TYPE -2 AND TYPE -1 ERROR NORMS ARE BOTH .LE. TOLCON
C WE RETURN WITH ICORCT=-1.
C NOTE THAT IN THEORY THE TYPE -1 CONSTRAINTS SHOULD BE NO PROBLEM,
C BUT OCCASIONALLY THEY ARE VIOLATED DUE TO ROUNDOFF ERROR OR
C PROBLEMS IN WOLFE, SO WE CHECK THEM TO BE SAFE.
      IF(ERR1(NUMGR+3)-TOLCON)450,450,550
  450 IF(ERR1(NUMGR+2)-TOLCON)500,500,600
  500 ICORCT=-1
      RETURN
C
C HERE THE TYPE -2 ERROR NORM IS .GT. TOLCON AND WE CALL RCHMOD WITH
C IRCH=-1 TO SEE IF RCHIN SHOULD BE INCREASED.
  550 CALL RCHMOD(NUMGR,ERROR,ERR1,ICNTYP,MACT,IACT,IPMAX,ISMAX,
     *UNIT,-1,RCHDWN,RCHIN)
C
C PUT PARPRJ INTO THE WORK VECTOR ZWORK SO PARPRJ ITSELF WILL REMAIN
C UNCHANGED UNLESS CORRCT IS SUCCESSFUL IN CORRECTING BACK INTO THE
C FEASIBLE REGION.
  600 DO 630 J=1,NPARM
        ZWORK(J)=PARPRJ(J)
  630   CONTINUE
C COMPUTE EOLD = MAX(ERR1(NUMGR+2),ERR1(NUMGR+3)).  NOTE THAT EOLD IS
C POSITIVE SINCE OTHERWISE WE WOULD HAVE RETURNED ABOVE (ASSUMING
C TOLCON .GE. 0.0).  THUS IF ONLY ONE TYPE OF STANDARD CONSTRAINT IS
C PRESENT, THE FACT THAT ERR1(NUMGR+2) OR ERR1(NUMGR+3) IS ZERO WILL
C DO NO HARM.
      EOLD=ERR1(NUMGR+3)
      IF(ERR1(NUMGR+2)-EOLD)670,670,650
  650 EOLD=ERR1(NUMGR+2)
C
C STATEMENTS ABOVE THIS POINT WILL NOT BE EXECUTED AGAIN IN THIS CALL
C TO CORRCT.
C NOW WE SET UP PMAT FOR USE IN WOLFE TO TRY TO COMPUTE A VECTOR DVEC
C POINTING BACK INTO THE FEASIBLE REGION.
C IF IOPTTH=1 WE CALL DERST ONCE TO PUT THE STANDARD
C GRADIENTS IN CONFUN.
  670 IF(IOPTTH)800,800,700
C WE SET IPT=-1 TO TELL DERST TO COMPUTE STANDARD CONSTRAINTS ONLY.
  700 IPT=-1
      CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARWRK,IPT,
     *WORK(ILC24),WORK(ILC35),IWORK(ILC22),CONFUN)
C
  800 L=0
      DO 1700 I=1,NUMGR
        IF(ICNTYP(I)+1)900,1000,1700
C
C HERE ICNTYP(I)=-2 AND WE WILL INCLUDE CONSTRAINT I IF AND ONLY IF
C ERR1(I) .GE. -RCHIN*PROJCT.  WHEN ICNTYP(I)=-1 WE HAVE A LINEAR
C STANDARD CONSTRAINT AND IT WILL ALWAYS BE INCLUDED.
  900   IF(ERR1(I)+RCHIN*PROJCT)1700,1000,1000
C
 1000   IF(IOPTTH)1100,1100,1200
C
C HERE IOPTTH=0 AND WE HAVE NOT YET PLACED THE GRADIENT OF THE LEFT
C SIDE OF CONSTRAINT I IN CONFUN(I,.) SO WE DO IT NOW.
 1100   IPT=I
        CALL DERST(IOPTN,NPARM,NUMGR,PTTBL,IPTB,INDM,PARWRK,IPT,
     *  WORK(ILC24),WORK(ILC35),IWORK(ILC22),CONFUN)
C
 1200   L=L+1
C PUT THE GRADIENT OF THE LEFT SIDE OF CONSTRAINT I IN PMAT(1,L),...,
C PMAT(NPARM,L).
        DO 1300 K=1,NPARM
          PMAT(K,L)=CONFUN(I,K+1)
 1300     CONTINUE
C
C SET ROW NPARM+1 OF PMAT.  WE WILL USUALLY SET PMAT(NPARM+1,L)=
C ERR1(I), SO THE WOLFE CONSTRAINT WILL BE GRADIENT(I).DVEC + ERR1(I)
C .LE. 0.0, I.E. (-GRADIENT(I)).DVEC .GE. ERR1(I).  THE EXCEPTION
C OCCURS WHEN ICNTYP(I)=-1 AND ERR1(I) .LT. 0.0, IN WHICH CASE WE
C REPLACE ERR1(I) BY ERR1(I)/2.0, IN ORDER TO INSURE THAT EVEN IF PROCOR
C TAKES ON ITS MAXIMUM ALLOWED VALUE OF 2.0, NO LINEAR STANDARD
C CONSTRAINT WITH NEGATIVE VALUE WILL BECOME POSITIVE VALUED (IGNORING
C ROUNDOFF ERROR).  NOTE THAT IF WE DENOTE CONSTRAINT I BY G(I)  .LE.
C 0.0, THEN OUR INEQUALITIES BECOME (GRAD G)(I).DVEC .LE. -G(I) (OR
C -G(I)/2.0), SO A SOLUTION DVEC IS A SOLUTION OF (GRAD G)(I).DVEC =
C -G(I) - EPS(I) WHERE EPS(I) = -(GRAD G)(I).DVEC - G(I) = -(GRAD G)(I).
C DVEC - G(I)/2.0 - G(I)/2.0 .GE. 0.0.  NOW WITH H(I) = G(I) + EPS(I)
C WE HAVE (GRAD H)(I).DVEC = -H(I), SO IF THIS SYSTEM IS SQUARE THEN
C PROCOR=1.0 GIVES A NEWTON STEP FOR SOLVING H(I)=0.0, I.E. G(I) =
C -EPS(I) .LE. 0.0.  THUS WE HAVE A KIND OF GENERALIZED NEWTON METHOD.
        IF(ICNTYP(I)+1)1500,1400,1500
 1400   IF(ERR1(I))1600,1500,1500
 1500   PMAT(NPAR1,L)=ERR1(I)
        GO TO 1700
 1600   PMAT(NPAR1,L)=ERR1(I)/TWO
 1700   CONTINUE
C
C CALL WOLFE WITH ISTRT=0 TO COMPUTE DVEC FROM SCRATCH.
      CALL WOLFE(NPARM,L,PMAT,0,S,NCOR,IWORK(ILC16),IWORK,LIWRK,WORK,
     *LWRK,WORK(ILC33),WORK(ILC06),WORK(ILC31),WORK(ILC30),NPARM,
     *NUMGR,WORK(ILC41),DVEC,WDIST,NMAJ,NMIN,JFLAG)
      IF(JFLAG)1900,1900,1800
C
C HERE WE WERE UNABLE TO OBTAIN A FEASIBLE PARPRJ AND WE RETURN WITH
C THE WARNING ICORCT=1.
 1800 ICORCT=1
      RETURN
C
C IN SEARCR AND MULLER WE WILL COMPUTE THE ERROR NORM FOR TYPE -2 AND
C TYPE -1 CONSTRAINTS, SO WE LUMP THESE TOGETHER BY SETTING
C JCNTYP(I)=-2 IF IT WAS -1.
 1900 DO 1975 I=1,NUMGR
        IF(JCNTYP(I)+1)1975,1960,1975
 1960   JCNTYP(I)=-2
 1975   CONTINUE
C CALL SEARCR TO TRY TO FIND PROCOR SO THAT WITH PARAMETER VECTOR
C (OLD) ZWORK + PROCOR*DVEC WE WILL HAVE EMIN = MAX(ERR1(NUMGR+2),
C ERR1(NUMGR+3)) .LE. TOLCON.  IF SEARCR SUCCEEDS IT WILL RETURN WITH
C ISRCR=0, WHILE IF IT FAILS IT WILL RETURN WITH ISRCR=1.  IN BOTH
C CASES ZWORK WILL BE THE SAME AS BEFORE THE CALL TO SEARCR.
      CALL SEARCR(IOPTN,NPARM,NUMGR,DVEC,FUN,IFUN,PTTBL,IPTB,
     *INDM,ZWORK,TOLCON,IPHSE,IWORK,LIWRK,WORK,LWRK,PARWRK,
     *ERR1,P1,F1,PROCOR,EMIN,ISRCR)
      IF(ISRCR)2000,2000,1980
C
 1980 NEWTIT=NEWTIT+1
      IF(NEWTIT-NEWTLM)1983,1800,1800
 1983 IF(EMIN-GAIN*EOLD)1986,1986,1800
C HERE WE UPDATE ZWORK, EOLD, PARWRK, AND ERR1, AND TRY ANOTHER NEWTON
C STEP WITH SEARCR.
 1986 EOLD=EMIN
      DO 1989 J=1,NPARM
        ZWORK(J)=ZWORK(J)+PROCOR*DVEC(J)
        PARWRK(J)=ZWORK(J)
 1989   CONTINUE
C WE TAKE IPHSE=-3 AS A KLUDGE TO TELL ERCMP1 TO COMPUTE ONLY STANDARD
C ERRORS IF THE TEN THOUSANDS DIGIT OF IOPTN IS 1, THUS SAVING ERCMP1 THE
C WORK OF SCANNING ICNTYP.
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,PARWRK,
     *1,-3,IWORK,LIWRK,CONFUN,JCNTYP,IPMAX,ISMAX,ERR1)
      GO TO 670
C
 2000 IF(EMIN+TOLCON)2100,2200,2200
C
C HERE THE MAXIMUM STANDARD CONSTRAINT ERROR IS SMALLER
C THAN -TOLCON.  SINCE OVERCORRECTION MAY ADVERSELY AFFECT CONVERGENCE,
C WE CALL MULLER TO TRY TO GET THE MAXIMUM STANDARD CONSTRAINT
C ERROR INTO THE CLOSED INTERVAL (-TOLCON, TOLCON) BY FURTHER
C MODIFYING PROCOR.
 2100 CALL MULLER(IOPTN,NPARM,NUMGR,DVEC,FUN,IFUN,PTTBL,IPTB,
     *INDM,ZWORK,TOLCON,IPHSE,IWORK,LIWRK,WORK,LWRK,PARWRK,
     *ERR1,P1,F1,PROCOR,EMIN)
C
C NOW COMPUTE PARPRJ = ZWORK + PROCOR*DVEC, SET ICORCT=0, AND RETURN.
 2200 DO 2300 J=1,NPARM
        PARPRJ(J)=ZWORK(J)+PROCOR*DVEC(J)
 2300   CONTINUE
      ICORCT=0
      RETURN
      END
      SUBROUTINE SEARCR(IOPTN,NPARM,NUMGR,DVEC,FUN,IFUN,PTTBL,
     *IPTB,INDM,ZWORK,TOLCON,IPHSE,IWORK,LIWRK,WORK,LWRK,
     *PARWRK,ERR1,P1,F1,PROCOR,EMIN,ISRCR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION FUN(IFUN),PTTBL(IPTB,INDM),PARWRK(NPARM),ERR1(NUMGR+3),
     *ZWORK(NPARM),DVEC(NPARM),IWORK(LIWRK),WORK(LWRK)
C
C THIS SUBROUTINE USES A MODIFIED QUADRATIC FITTING PROCESS TO SEARCH
C FOR A PROJECTION FACTOR PROCOR FOR WHICH THE MAXIMUM OF THE LEFT
C SIDES OF THE TYPE -2 AND -1 CONSTRAINTS EVALUATED AT ZWORK + PROCOR*DVEC
C IS .LE. TOLCON.  NOTE THAT WHEN CORRCT CALLS THIS SUBROUTINE IT WILL
C HAVE LUMPED THE TYPE -1 CONSTRAINTS IN WITH THE TYPE -2 CONSTRAINTS
C USING JCNTYP, WHICH IS CARRIED THROUGH THIS SUBROUTINE INTO SUBROUTINE
C ERCMP1 IN IWORK.  IF SEARCR IS ABLE TO FORCE THIS MAXIMUM .LE. TOLCON
C IT WILL RETURN WITH ISRCR=0, WITH THE MINIMUM VALUE FOUND FOR THE
C MAXIMUM IN EMIN, WITH THE CORRESPONDING PROJECTION FACTOR IN PROCOR,
C WITH THE NUMBER OF TIMES THE MAXIMUM WAS COMPUTED IN NSRCH, AND WITH THE
C CLOSEST POINT FOUND TO THE LEFT WITH THE MAXIMUM .GT. TOLCON IN (P1,F1).
C THE SUBROUTINE WILL BEGIN BY COMPUTING THE MAXIMA FOR PROCOR = 1.0,
C 0.5, AND 2.0, AND IF NONE OF THESE MAXIMA IS .LE. TOLCON AND IT IS
C NOT THE CASE THAT THE MAXIMUM AT 1.0 IS .LE. THE OTHER TWO MAXIMA
C THE SUBROUTINE WILL RETURN WITH THE WARNING ISRCR=1. THE SUBROUTINE
C WILL ALSO RETURN WITH ISRCR=1 IF IT WOULD NEED TO COMPUTE F MORE THAN
C LIMSCR TIMES, OR THE SEARCH INTERVAL LENGTH DROPS BELOW TOL1, OR THE
C QUADRATIC FIT BECOMES TOO FLAT.  EVEN IN THE EVENT OF A RETURN WITH
C ISRCR=1, EMIN, PROCOR, AND NSRCH WILL BE AS ABOVE.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      TOLDEN=TEN*SPCMN
      TOL1=TEN*TEN*SPCMN
      TOL4=TOL1/FOUR
      BALFCT=TEN
      BALADJ=(TEN-ONE)/TEN
      ILC08=ILOC(8,NPARM,NUMGR)
      ILC21=ILOC(21,NPARM,NUMGR)
      LIMSCR=6
      PROCOR=ONE
      P1=ZERO
      F1=ERR1(NUMGR+3)
      F1KP=F1
      ISRCR=0
      NSRCH=0
      ILF=0
      IRT=0
C IF AFTER LIMSCR ITERATIONS HAVE BEEN DONE (WHERE LIMSCR .GE. 4) THE
C BEST VALUE FOUND IS .LE. PROGR WE WILL (ONCE ONLY) BUMP LIMSCR UP BY
C IADDL, SINCE THERE WOULD SEEM TO BE A GOOD CHANCE THAT THIS WILL
C PRODUCE SUCCESS.
C SETTING IEXT=1 HERE WILL DISABLE THE BUMPING PROCEDURE.
      IEXT=0
      IADDL=6
      PROGR=TEN*TEN*TEN*TOLCON
C WE NOW TRY TO COMPUTE VALUES AT POINTS P2=PROCOR, P1=P2/2.0, AND
C P3=2.0*P2.
      P2=PROCOR
C SET LLL=2 AS THE THREAD THROUGH THE MINOTAURS CAVERN AND JUMP
C DOWN TO PUT F(P2) IN F2.  WE WILL JUMP BACK AFTER ALL SUCH JUMPS
C UNLESS LIMSCR WOULD BE EXCEEDED.
      LLL=2
      PVAL=P2
      GO TO 3500
C
   77 F2=FVAL
      P1=P2/TWO
C SET LLL=1 AND PUT F(P1) IN F1.
      LLL=1
      PVAL=P1
      GO TO 3500
C
   97 F1=FVAL
      P3=TWO*P2
C HERE SET LLL=3 AND PUT F(P3) IN F3.
      LLL=3
      PVAL=P3
      GO TO 3500
C
  187 F3=FVAL
C
C WE NOW HAVE FOUND P1, P2, AND P3 WITH CORRESPONDING VALUES
C F1, F2, AND F3, AND WE CHECK WHETHER F2 .LE. MIN(F1,F3).
  280 IF(F2-F1)500,500,300
  300 IF(F1-F3)350,350,400
  350 EMIN=F1
      PROCOR=ONE/TWO
      GO TO 12000
  400 EMIN=F3
      PROCOR=TWO
      GO TO 12000
C
C HERE F2 .LE. F1.  IF F2 .LE. F3 WE ARE DONE INITIALIZING.
  500 IF(F2-F3)1100,1100,400
C END OF INITIALIZATION.
C
C ASSUMING THAT P3-P1 .GE. TOL1, WE NOW HAVE POINTS P1, P2, P3 WITH
C P1 .LE. P2-TOL4, P2 .LE. P3-TOL4, F1=F(P1) .GE. F2=F(P2), AND F3=F(P3)
C .GE. F2.  THESE CONDITIONS WILL BE MAINTAINED THROUGHOUT THE PROGRAM.
C SET LLL=4, WHERE IT WILL REMAIN FROM NOW ON.
 1100 LLL=4
C
C IF THE SEARCH INTERVAL LENGTH IS LESS THAN TOL1 WE HAVE FAILED.
 1200 IF(P3-P1-TOL1)1300,1400,1400
C
 1300 EMIN=F2
      PROCOR=P2
      GO TO 12000
C
C COMPUTE S1 = THE ABSOLUTE VALUE OF THE SLOPE OF THE LINE THROUGH
C (P1,F1) AND (P2,F2), AND S2 = THE (ABSOLUTE VALUE OF THE) SLOPE
C OF THE LINE THROUGH (P2,F2) AND (P3,F3).
 1400 S1=(F1-F2)/(P2-P1)
      S2=(F3-F2)/(P3-P2)
C IF S1+S2 IS VERY SMALL WE HAVE FAILED.
      IF(S1+S2-TOLDEN)1300,1600,1600
C
 1600 RLF=S2/(S1+S2)
      RRT=ONE-RLF
C THE MINIMUM OF THE QUADRATIC POLYNOMIAL PASSING THROUGH
C (P1,F1), (P2,F2), AND (P3,F3) WILL OCCUR AT (RLF*P1+
C RRT*P3+P2)/2.0.  NOTE THAT THE THREE POINTS CANNOT BE
C COLLNEAR, ELSE WE WOULD HAVE TERMINATED ABOVE.  SINCE THE
C MINIMUM OCCURS AT THE AVERAGE OF P2 AND A CONVEX COMBINATION
C OF P1 AND P3, IT WILL BE AT LEAST AS CLOSE TO P2 AS TO THE
C ENDPOINT ON THE SAME SIDE.
      IF(ILF-1)1800,1800,1700
C HERE THE LEFT ENDPOINT WAS DROPPED AT THE LAST ILF .GT. 1
C ITERATIONS, SO TO PREVENT A LONG STRING OF SUCH OCCURRENCES
C WITH LITTLE REDUCTION OF P3-P1 WE WILL SHIFT THE NEW POINT
C TO THE RIGHT BY DECREASING RLF RELATIVE TO RRT.
 1700 RLF=RLF/TWO**(ILF-1)
      RRT=ONE-RLF
      GO TO 2400
 1800 IF(IRT-1)2000,2000,1900
C HERE THE RIGHT ENDPOINT WAS DROPPED AT THE LAST IRT .GT. 1
C ITERATIONS, AND WE WILL SHIFT THE NEW POINT TO THE LEFT.
 1900 RRT=RRT/TWO**(IRT-1)
      RLF=ONE-RRT
      GO TO 2400
C HERE WE HAVE NOT JUST HAD A STRING OF TWO OR MORE MOVES IN
C THE SAME DIRECTION, BUT IF THE SUBINTERVALS ARE OUT OF
C BALANCE BY MORE THAN A FACTOR OF BALFCT, WE SHIFT THE NEW
C POINT SLIGHTLY IN THE DIRECTION OF THE LONGER INTERVAL.  THE
C IDEA HERE IS THAT THE TWO CLOSE POINTS ARE PROBABLY NEAR THE
C SOLUTION, AND IF WE CAN BRACKET THE SOLUTION WE MAY BE ABLE TO
C CUT OFF THE MAJOR PORTION OF THE LONGER SUBINTERVAL.
 2000 IF(P2-P1-BALFCT*(P3-P2))2200,2200,2100
C HERE THE LEFT SUBINTERVAL IS MORE THAN BALFCT TIMES LONGER THAN
C THE RIGHT SUBINTERVAL, SO WE DECREASE RRT RRELATIVE TO RLF.
 2100 RRT=BALADJ*RRT
      RLF=ONE-RRT
      GO TO 2400
 2200 IF(P3-P2-BALFCT*(P2-P1))2400,2400,2300
C HERE THE RIGHT SUBINTERVAL IS MORE THAN BALFCT TIMES LONGER
C THAN THE LEFT SUBINTERVAL, SO WE DECREASE RLF RELATIVE TO RRT.
 2300 RLF=BALADJ*RLF
      RRT=ONE-RLF
C
C COMPUTE THE (POSSIBLY MODIFIED) MINIMUM OF THE QUADRATIC FIT.
 2400 P4=(RLF*P1+RRT*P3+P2)/TWO
C
C THE NEXT SECTION (FROM HERE TO STATEMENT 2800) MODIFIES P4, IF
C NECESSARY, TO GET P1+TOL4 .LE. P2,P4 .LE. P3-TOL4 AND ABS(P4-P2) .GE.
C TOL4.  THIS SECTION IS LESS COMPLICATED THAN THE CORRESPONDING SECTION
C IN SEARSL BECAUSE ALL PS LIE BETWEEN 0.5 AND 2.0, SO WEIRD ROUNDOFF
C EFFECTS ARE LESS LIKELY.
C IF ABS(P4-P2) .LT. TOL4 WE REDEFINE P4 BY MOVING TOL4 FROM
C P2 INTO THE LONGER SUBINTERVAL.  NOTE THAT THE LENGTH OF THIS
C SUBINTERVAL MUST BE AT LEAST TOL1/2.0 = 2.0*TOL4, ELSE WE
C WOULD HAVE TERMINATED EARLIER.
      IF(ABS(P4-P2)-TOL4)2500,2710,2710
 2500 IF(P3-P2-(P2-P1))2700,2700,2600
 2600 P4=P2+TOL4
      GO TO 2800
 2700 P4=P2-TOL4
      GO TO 2800
C HERE WE HAD ABS(P4-P2) .GE. TOL4 AND WE MAKE SURE THAT P1+TOL4
C .LE. P4 .LE. P3-TOL4.
 2710 IF(P4-(P3-TOL4))2740,2740,2720
C HERE P4 .GT. P3-TOL4 AND WE SET P4=P3-TOL4 IF P3-P2 .GE. TOL1/2.0,
C AND OTHERWISE WE SET P4=P2-TOL4.
 2720 IF(P3-P2-TOL1/TWO)2700,2730,2730
 2730 P4=P3-TOL4
      GO TO 2800
 2740 IF(P4-(P1+TOL4))2750,2800,2800
C HERE P4 .LT. P1+TOL4 AND WE SET P4=P1+TOL4 IF P2-P1 .GE. TOL1/2.0
C AND OTHERWISE WE SET P4=P2+TOL4.
 2750 IF(P2-P1-TOL1/TWO)2600,2760,2760
 2760 P4=P1+TOL4
C
C NOW JUMP DOWN TO PUT F(P4) IN F4.
 2800 PVAL=P4
      GO TO 3500
C
 2877 F4=FVAL
C
C NOW WE DROP EITHER P1 OR P3 AND RELABEL THE REMAINING POINTS (IF
C NECESSARY) SO THAT F(P2) .LE. F(P1) AND F(P2) .LE. F(P3).
C IF NOW THE LEFTMOST OF THE TWO MIDDLE POINTS IS LOWER THAN THE
C RIGHTMOST OF THE TWO MIDDLE POINTS WE DROP P3, AND SET ILF=0
C AND INCREMENT IRT TO INDICATE THE RIGHT END POINT HAS BEEN DROPPED.
C OTHERWISE WE DROP P1, SET IRT=0 AND INCREMENT ILF.  IN ALL CASES
C WE THEN RESHUFFLE THE VALUES INTO P1, P2, P3, F1, F2, F3 AND TRY
C TO DO ANOTHER ITERATION.
      IF(P4-P2)2900,3200,3200
C HERE P4 .LT. P2.
 2900 IF(F4-F2)3000,3100,3100
 3000 P3=P2
      F3=F2
      P2=P4
      F2=F4
      ILF=0
      IRT=IRT+1
      GO TO 1200
 3100 P1=P4
      F1=F4
      ILF=ILF+1
      IRT=0
      GO TO 1200
C HERE P4 .GT. P2.
 3200 IF(F2-F4)3300,3400,3400
 3300 P3=P4
      F3=F4
      ILF=0
      IRT=IRT+1
      GO TO 1200
 3400 P1=P2
      F1=F2
      P2=P4
      F2=F4
      ILF=ILF+1
      IRT=0
      GO TO 1200
C
C WE INCREMENT NSRCH SINCE WE ARE ABOUT TO COMPUTE F.
 3500 NSRCH=NSRCH+1
C
C
C THIS IS WHERE WE COMPUTE THE MAXIMUM FVAL = F(PVAL) OF THE LEFT SIDES
C OF THE TYPE -2 AND TYPE -1 CONSTRAINTS.
C
C PROJECT DVEC TO GET PARWRK.
      DO 4000 J=1,NPARM
        PARWRK(J)=ZWORK(J)+PVAL*DVEC(J)
 4000   CONTINUE
C WE TAKE IPHSE=-3 AS A KLUDGE TO TELL ERCMP1 TO COMPUTE ONLY STANDARD
C ERRORS IF THE TEN THOUSANDS DIGIT OF IOPTN IS 1, THUS SAVING ERCMP1
C THE WORK OF SCANNING ICNTYP.
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARWRK,1,-3,IWORK,LIWRK,WORK(ILC08),IWORK(ILC21),IPMAX,
     *ISMAX,ERR1)
      FVAL=ERR1(NUMGR+3)
C
      IF(FVAL-TOLCON)4100,4100,5500
C
C HERE FVAL .LE. TOLCON AND WE RETURN AFTER SETTING PROCOR, EMIN, P1,
C AND F1.
 4100 PROCOR=PVAL
      EMIN=FVAL
C IF LLL=1 TAKE P1=0.0 AND F1=F1KP, IF LLL=2 LEAVE P1 AND F1 ALONE (THEY
C WILL BE 0.0 AND FIKP RESPECTIVELY), IF LLL=3 TAKE P1=P2 AND F1=F2,
C IF LLL=4 AND P2 .LT. P4 TAKE P1=P2 AND F1=F2, AND IF LLL=4 AND
C P2 .GE. P4 LEAVE P1 AND F1 ALONE.  IN ALL CASES (P1,F1) WILL BE THE
C POINT WITH P1 THE NEAREST VALUE LEFT OF PROCOR CONSIDERED AND WE WILL
C HAVE F1 .GT. TOLCON.
      GO TO (5100,5200,5300,5400),LLL
 5100 P1=ZERO
      F1=F1KP
 5200 RETURN
 5300 P1=P2
      F1=F2
      RETURN
 5400 IF(P2-P4)5300,5200,5200
C
C HERE FVAL .GT. TOLCON AND WE SEE IF LIMSCR ITERATIONS IN SEARCR HAVE
C BEEN DONE.  IF SO WE SET THE FAILURE WARNING ISRCR=1 AND RETURN
C UNLESS WE CHOOSE TO INCREASE LIMSCR.
 5500 IF(NSRCH-LIMSCR)12100,5600,5600
C
C HERE WE HAVE DONE LIMSCR ITERATIONS.
 5600 IF(IEXT)5800,5800,11000
 5800 IF(FVAL-PROGR)6000,6000,5900
 5900 IF(F2-PROGR)6000,6000,11000
C HERE WE HAVE NOT BUMPED LIMSCR EARLIER, LIMSCR .GE. 4, AND
C MIN(FVAL,F2) .LE. PROGR, SO WE BUMP LIMSCR.
 6000 IEXT=1
      LIMSCR=LIMSCR+IADDL
      GO TO 12100
C
11000 CONTINUE
C11000 WRITE(NWRIT,11500)
C11500 FORMAT(30H *****WARNING*****WARNING*****,
C    *30H TOO MANY ITERATIONS IN SEARCR)
C
C HERE WE HAVE FAILED AND WE SET EMIN AND PROCOR FOR OUTPUT, SET ISRCR=1,
C AND RETURN.
      IF(FVAL-F2)11600,11600,1300
11600 EMIN=FVAL
      PROCOR=PVAL
C
12000 ISRCR=1
      RETURN
C
C HERE WE WILL CARRY THE COMPUTED F VALUE BACK TO THE APPROPRIATE PART
C OF THE PROGRAM.
12100 GO TO (97,77,187,2877),LLL
      END
      SUBROUTINE MULLER(IOPTN,NPARM,NUMGR,DVEC,FUN,IFUN,PTTBL,
     *IPTB,INDM,ZWORK,TOLCON,IPHSE,IWORK,LIWRK,WORK,LWRK,
     *PARWRK,ERR1,P1,F1,PROCOR,EMIN)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION DVEC(NPARM),FUN(IFUN),PTTBL(IPTB,INDM),ZWORK(NPARM),
     *ERR1(NUMGR+3),PARWRK(NPARM),IWORK(LIWRK),WORK(LWRK)
C
C IN THIS SUBROUTINE WE ARE GIVEN A BASE VECTOR ZWORK, A DIRECTION
C VECTOR DVEC, A SCALAR PROCOR WITH EMIN = F(PROCOR) = (THE MAXIMUM TYPE
C -2 AND -1 ERROR WITH PARAMETERS ZWORK + PROCOR*DVEC) .LT. -TOLCON, AND
C A SCALAR P1 WITH P1 .LT. PROCOR AND F1 = F(P1) .GT. TOLCON.  WE DO
C A REVISED MULLERS METHOD APPROACH (WITH A SOLUTION CONTAINED IN A
C SHRINKING INTERVAL) TO ATTEMPT TO ADJUST PROCOR SO THAT -TOLCON  .LE.
C F(PROCOR) .LE. TOLCON, BUT IF WE ARE NOT SUCCESSFUL WE RETURN WITH THE
C LEFTMOST PROCOR FOUND SATISFYING EMIN = F(PROCOR) .LT. -TOLCON ON THE
C THEORY THAT OVERCORRECTION IS BETTER THAN NO CORRECTION.  NOTE THAT WHEN
C CORRCT CALLS THIS SUBROUTINE IT WILL HAVE LUMPED THE TYPE -1 CONSTRAINTS
C IN WITH THE TYPE -2 CONSTRAINTS USING JCNTYP, WHICH IS CARRIED THROUGH
C THIS SUBROUTINE INTO SUBROUTINE ERCMP1 IN IWORK.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      TOL1=TEN*TEN*SPCMN
      TOL4=TOL1/FOUR
      TOLDEN=TEN*SPCMN
      ILC08=ILOC(8,NPARM,NUMGR)
      ILC21=ILOC(21,NPARM,NUMGR)
      LIMMUL=5
      NSRCH=0
      IMAIN=0
C
      P3=PROCOR
      F3=EMIN
C WE DO NOT ALLOW THE LENGTH OF THE INTERVAL (P1,P3) TO FALL BELOW
C TOL1.
   50 IF(P3-P1-TOL1)100,200,200
  100 RETURN
C
C COMPUTE P2 = (P1+P3)/2.0 AND F(P2).
  200 P2=(P1+P3)/TWO
      PVAL=P2
C SET LLL AS THE THREAD THROUGH THE MINOTAURS CAVERN AND JUMP DOWN TO
C COMPUTE F(PVAL)=F(P2).  WE WILL JUMP BACK AFTER ALL SUCH JUMPS.
      LLL=1
      GO TO 3500
  277 F2=FVAL
      IF(F2-TOLCON)300,300,500
  300 IF(F2+TOLCON)500,400,400
C
C HERE -TOLCON .LE. F2 .LE. TOLCON AND WE RETURN WITH PROCOR=P2 AND
C EMIN=F2.
  400 PROCOR=P2
      EMIN=F2
      RETURN
C
C HERE WE HAVE NOT ACHIEVED SUCCESS YET AND WE SEE IF THE ITERATION
C LIMIT HAS BEEN REACHED.
  500 IF(NSRCH-LIMMUL)1500,600,600
C
C HERE WE HAVE REACHED THE ITERATION LIMIT WITHOUT SUCCESS.  WE RETURN
C WITH PROCOR = THE LEFTMOST OF THE THREE POINTS P2, P4, AND P3 WHICH
C HAS NEGATIVE F VALUE (UNLESS IMAIN=0, IN WHICH CASE WE IGNORE P4).
  600 CONTINUE
C 600 WRITE(NWRIT,700)
C 700 FORMAT(45H ***WARNING  TOO MANY ITERATIONS IN MULLER***)
      IF(IMAIN)1400,1400,750
  750 IF(P2-P4)800,800,1300
C
C HERE P2 .LT. P4.
  800 IF(F2)400,1000,1000
C
 1000 IF(F4)1100,1200,1200
 1100 PROCOR=P4
      EMIN=F4
      RETURN
C
 1200 PROCOR=P3
      EMIN=F3
      RETURN
C
C HERE P4 .LT. P2.
 1300 IF(F4)1100,1400,1400
 1400 IF(F2)400,1200,1200
C
C HERE WE HAVE NOT REACHED THE ITERATION LIMIT SO WE TRY AGAIN.
C IF IMAIN=0 HERE WE WILL HAVE NO P4 TO SHUFFLE IN, AND WE WILL HAVE
C ALREADY CHECKED P3-P1 .GE. TOL1, SO WE RESET IMAIN TO 1 AND DO A FIT.
 1500 IF(IMAIN)2550,2550,1600
C
C HERE WE HAVE POINTS P1, P2, P3, P4 WITH P1+TOL1/4.0 .LE. P2 .LE.
C P3-TOL1/4.0, P1+TOL1/4.0 .LE. P4 .LE. P3-TOL1/4.0, ABS(P4-P2) .GE.
C TOL1/4.0, F(P1) .GT. TOLCON, F(P3) .LT. -TOLCON, ABS(F(P2)) .GT.
C TOLCON, AND ABS(F(P4)) .GT. TOLCON.  WE WILL NOW DISCARD EITHER
C P1 OR P3 AND RELABEL TO GET NEW POINTS P1, P2, P3, EXCEPT IN ONE
C CASE WHERE TWO POINTS WILL BE DISCARDED AND WE WILL RELABEL TO GET
C NEW POINTS P1, P3.
C IF P2 .GT. P4 HERE WE WILL, IN THE INTEREST OF A MORE READABLE
C PROGRAM, INTERCHANGE P2 AND P4 (AND F2 AND F4) SO WE WILL BE ABLE
C TO ASSUME P2 .LE. P4.
 1600 IF(P2-P4)1800,1800,1700
 1700 TEMP=P2
      P2=P4
      P4=TEMP
      TEMP=F2
      F2=F4
      F4=TEMP
 1800 IF(F2)2200,2200,1900
C
C HERE F2 .GT. 0.0.
 1900 IF(F4)2100,2100,2000
C
C HERE EITHER F2 .GT. 0.0 AND F4 .GT. 0.0, OR ELSE F2 .GT. 0.0,
C F4 .LT. 0.0, AND P2-P1 .GT. P3-P4.  WE DISCARD P1, SINCE IN THE
C FORMER CASE THE FIRST THREE F VALUES ARE ALL POSITIVE, AND IN THE
C LATTER CASE ONLY THE FIRST TWO F VALUES ARE POSITIVE, BUT BY DROPPING
C P1 WE CAN GET MAXIMUM SHRINKAGE OF P3-P1.
 2000 P1=P2
      F1=F2
      P2=P4
      F2=F4
      GO TO 2500
C
C HERE F2 .GT. 0.0 AND F4 .LT. 0.0.
 2100 IF(P2-P1-(P3-P4))2300,2300,2000
C
C HERE F2 .LT. 0.0.
 2200 IF(F4)2300,2300,2400
C
C HERE EITHER F2 .LT. 0.0 AND F4 .LT. 0.0, OR ELSE F2 .GT. 0.0,
C F4 .LT. 0.0, AND P2-P1 .LE. P3-P4.  WE DISCARD P3, SINCE IN THE
C FORMER CASE THE LAST THREE F VALUES ARE NEGATIVE, AND IN THE LATTER
C CASE ONLY THE LAST TWO F VALUES ARE NEGATIVE, BUT BY DROPPING P3 WE
C GET MAXIMUM SHRINKAGE OF P3-P1.
 2300 P3=P4
      F3=F4
      GO TO 2500
C
C HERE F2 .LT. 0.0 AND F4 .GT. 0.0, AND IN THIS SAWTOOTH PATTERN WE
C DISCARD BOTH P4 AND P3, SET IMAIN=0, AND GO BACK TO THE BEGINNING
C (EXCEPT NSRCH CONTINUES TO INCREASE, INSURING EVENTUAL TERMINATION).
 2400 IMAIN=0
      P3=P2
      F3=F2
      PROCOR=P3
      EMIN=F3
      GO TO 50
C
C HERE WE HAVE THREE POINTS.  IF P3-P1 .LT. TOL1 WE WILL RETURN AFTER
C SETTING PROCOR AND EMIN.
 2500 IF(P3-P1-TOL1)1400,2550,2550
C
C HERE WE RESET IMAIN TO 1 AND COMPUTE P4, THE UNIQUE ZERO IN THE
C INTERVAL (P1,P3) OF THE QUADRATIC POLYNOMIAL WHICH PASSES THROUGH
C (P1,F1), (P2,F2), AND (P3,F3).  RECALL THAT F1 .GT. 0.0,
C F3 .LT. 0.0, AND P1+TOL1/4.0 .LE. P2 .LE. P3-TOL1/4.0.
 2550 IMAIN=1
C
C COMPUTE THE COEFFICIENTS ACOF, BCOF, AND CCOF OF OUR POLYNOMIAL
C ACOF*X**2 + BCOF*X + CCOF.
      ACOF=((F3-F2)*(P2-P1)-(F2-F1)*(P3-P2))/((P2-P1)*(P3-P2)*
     *(P3-P1))
      BCOF=(F3-F1)/(P3-P1)-ACOF*(P1+P3)
      CCOF=F2-P2*(ACOF*P2+BCOF)
      DISCR=BCOF**2-FOUR*ACOF*CCOF
C IN THEORY THE DISCRIMINANT SHOULD BE POSITIVE HERE, BUT TO BE SAFE WE
C CHECK IT IN CASE ROUNDOFF ERROR HAS MADE IT NEGATIVE.
      IF(DISCR)1400,2575,2575
 2575 IF(BCOF)2700,2700,2600
C
C HERE BCOF .GT. 0.0 AND WE USE THE USUAL FORM OF THE QUADRATIC
C FORMULA TO TRY TO REDUCE PROBLEMS WITH SUBTRACTION AND SMALL
C DENOMINATORS.  THE MINUS SIGN IS USED IN FRONT OF THE SQUARE ROOT
C BECAUSE IF ACOF .GT. 0.0 THEN THE POLYNOMIAL IS CONCAVE UP, WHICH
C IMPLIES P1 MUST BE ON THE LEFT BRANCH (SINCE F1 .GT. F3), WHICH
C IMPLIES WE WANT THE LEFT (I.E. SMALLER) ZERO, AGREEING WITH
C -SQRT(...)/ACOF .LE. 0.0.  IF ON THE OTHER HAND ACOF .LT. 0.0 THEN
C THE POLYNOMIAL IS CONCAVE DOWN, WHICH IMPLIES P3 MUST BE ON THE
C RIGHT BRANCH (SINCE F1 .GT. F3), WHICH IMPLIES WE WANT THE RIGHT
C (I.E. LARGER) ZERO, AGREEING WITH -SQRT(...)/ACOF .GE. 0.0.
C NOTE THAT ACOF=0.0 CANNOT OCCUR HERE SINCE IF IT DID THE POLYNOMIAL
C WOULD BE LINEAR, AND BCOF .GT. 0.0 WOULD THEN CONTRADICT F1 .GT. F3.
C STILL, TO BE SAFE, WE CHECK THE SIZE OF THE DENOMINATOR.
 2600 DEN=TWO*ACOF
      IF(ABS(DEN)-TOLDEN)1400,2650,2650
 2650 P4=(-BCOF-SQRT(DISCR))/DEN
      GO TO 2800
C
C HERE BCOF .LE. 0.0 AND WE USE THE ALTERNATE FORM OF THE QUADRATIC
C FORMULA.  NOTE THAT THE DENOMINATOR CANNOT BE ZERO SINCE THAT
C WOULD IMPLY BOTH BCOF=0.0 AND SQRT(...)=0.0, SO ALSO EITHER
C ACOF=0.0 OR CCOF=0.0, BUT THIS CONTRADICTS THE FACT THAT F1  .GT.
C 0.0 AND F3 .LT. 0.0.
C STILL, TO BE SAFE, WE CHECK THE SIZE OF THE DENOMINATOR.
 2700 DEN=-BCOF+SQRT(DISCR)
      IF(DEN-TOLDEN)1400,2750,2750
 2750 P4=TWO*CCOF/DEN
C
C THE NEXT SECTION (FROM HERE TO STATEMENT 3200) MODIFIES P4, IF
C NECESSARY, TO GET P1+TOL4 .LE. P2,P4 .LE. P3-TOL4 AND ABS(P4-P2) .GE.
C TOL4.
C
C IF ABS(P4-P2) .LT. TOL1/4.0 WE REDEFINE P4 BY MOVING IT A DISTANCE
C TOL1/4.0 FROM P2 INTO THE LONGER SUBINTERVAL.  NOTE THAT THE LENGTH
C OF THIS SUBINTERVAL MUST BE AT LEAST TOL1/2.0 SINCE P3-P1 .GE. TOL1.
 2800 IF(ABS(P4-P2)-TOL4)2900,3110,3110
 2900 IF(P3-P2-(P2-P1))3000,3000,3100
 3000 P4=P2-TOL4
      GO TO 3200
 3100 P4=P2+TOL4
      GO TO 3200
C HERE WE HAD ABS(P4-P2) .GE. TOL4 AND WE MAKE SURE THAT P1+TOL4
C .LE. P4 .LE. P3-TOL4.
 3110 IF(P4-(P3-TOL4))3140,3140,3120
C HERE P4 .GT. P3-TOL4 AND WE SET P4=P3-TOL4 IF P3-P2 .GE. TOL1/2.0,
C AND OTHERWISE WE SET P4=P2-TOL4.
 3120 IF(P3-P2-TOL1/TWO)3000,3130,3130
 3130 P4=P3-TOL4
      GO TO 3200
 3140 IF(P4-(P1+TOL4))3150,3200,3200
C HERE P4 .LT. P1+TOL4 AND WE SET P4=P1+TOL4 IF P2-P1 .GE. TOL1/2.0
C AND OTHERWISE WE SET P4=P2+TOL4.
 3150 IF(P2-P1-TOL1/TWO)3100,3160,3160
 3160 P4=P1+TOL4
C
C COMPUTE F4=F(P4).
 3200 PVAL=P4
      LLL=2
      GO TO 3500
C
 3277 F4=FVAL
C
C IF -TOLCON .LE. F4 .LE. TOLCON WE RETURN WITH PROCOR=P4 AND EMIN
C =F4, AND OTHERWISE WE GO BACK UP TO SEE IF WE HAVE REACHED THE LIMIT
C ON THE NUMBER OF STEPS.
      IF(F4-TOLCON)3300,3300,500
 3300 IF(F4+TOLCON)500,1100,1100
C
C NOW INCREMENT NSRCH SINCE WE ARE ABOUT TO COMPUTE F.
 3500 NSRCH=NSRCH+1
C
C
C HERE IS WHERE WE MUST SUPPLY A ROUTINE TO COMPUTE FVAL = F(PVAL) =
C THE MAXIMUM OF THE LEFT SIDES OF THE TYPE -2 AND -1 CONSTRAINTS.
C
C PROJECT DVEC TO GET PARWRK FOR USE IN ERCMP1.
      DO 3600 J=1,NPARM
        PARWRK(J)=ZWORK(J)+PVAL*DVEC(J)
 3600   CONTINUE
C WE TAKE IPHSE=-3 AS A KLUDGE TO TELL ERCMP1 TO COMPUTE ONLY STANDARD
C ERRORS IF THE TEN THOUSANDS DIGIT OF IOPTN IS 1, THUS SAVING ERCMP1
C THE WORK OF SCANNING ICNTYP.
      CALL ERCMP1(IOPTN,NPARM,NUMGR,FUN,IFUN,PTTBL,IPTB,INDM,
     *PARWRK,1,-3,IWORK,LIWRK,WORK(ILC08),IWORK(ILC21),IPMAX,
     *ISMAX,ERR1)
      FVAL=ERR1(NUMGR+3)
C
C CARRY THE COMPUTED F VALUE BACK TO THE APPROPRIATE PART OF THE PROGRAM.
      GO TO (277,3277),LLL
      END
      SUBROUTINE RCHMOD(NUMGR,ERROR,ERR1,ICNTYP,MACT,IACT,IPMAX,
     *ISMAX,UNIT,IRCH,RCHDWN,RCHIN)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION ERROR(NUMGR+3),ERR1(NUMGR+3),ICNTYP(NUMGR),IACT(NUMGR)
C
C THIS SUBROUTINE INCREASES RCHDWN OR RCHIN IF IT APPEARS SOME
C CONSTRAINTS WHICH SHOULD HAVE BEEN DECLARED ACTIVE WERE NOT SO
C DECLARED.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      FUDGE=ONE+ONE/TEN
      SPCMN=D1MACH(3)
      RCHTOP=ONE/SPCMN
      ENORM=ERROR(NUMGR+1)
C
      IF(IRCH)2000,50,50
C
C
C HERE IRCH=1 AND WE CONSIDER CHANGING RCHDWN.
C
C SEE IF CONSTRAINT IPMAX IS IN THE ACTIVE SET, AND RETURN IF IT IS.
C NOTE THAT IPMAX .GT. 0 SINCE THERE WILL BE AT LEAST ONE PRIMARY
C CONSTRAINT AT THIS STAGE (EVEN IF THERE WERE NONE IN THE ORIGINAL
C PROBLEM).
   50 DO 100 L=1,MACT
        I=IABS(IACT(L))
        IF(I-IPMAX)100,2700,100
  100   CONTINUE
C
C RETURN IF RCHDWN .GE. RCHTOP.
      IF(RCHDWN-RCHTOP)200,2700,2700
C
C WE WILL CONSIDER CHANGING RCHDWN IF THE NEW PRIMARY ERROR NORM WITH
C ONLY THE OLD ACTIVE CONSTRAINTS CONSIDERED IS LESS THAN THE OLD
C PRIMARY ERROR NORM, AND THIS WILL CERTAINLY BE THE CASE IF THE NEW
C PRIMARY ERROR NORM IS LESS THAN THE OLD PRIMARY ERROR NORM.
  200 IF(ERR1(NUMGR+1)-ENORM)1100,250,250
C
C COMPUTE EPACT, THE NEW PRIMARY ERROR NORM WITH ONLY THE OLD ACTIVE
C CONSTRAINTS CONSIDERED.
  250 IPACT=0
      DO 1000 L=1,MACT
        I=IABS(IACT(L))
        IF(ICNTYP(I)-1)1000,400,500
C HERE CONSTRAINT I WAS A PRIMARY ACTIVE CONSTRAINT.
  400   EI=ERR1(I)
        GO TO 600
  500   EI=ABS(ERR1(I))
  600   IF(IPACT)700,700,800
  700   IPACT=1
        EPACT=EI
        GO TO 1000
  800   IF(EI-EPACT)1000,1000,900
  900   EPACT=EI
 1000   CONTINUE
C
C WE WILL RETURN IF EPACT IS .GE. THE OLD PRIMARY ERROR NORM, WHICH
C WOULD INDICATE THAT THE STEP WAS TOO INACCURATE TO BE TRUSTED TO
C USE IN MODIFYING RCHDWN.
      IF(EPACT-ENORM)1100,2700,2700
C
C COMPUTE EIPMAX AS THE OLD ERROR AT CONSTRAINT IPMAX (IF ICNTYP(IPMAX)
C =1) OR THE OLD ABSOLUTE ERROR AT CONSTRAINT IPMAX (IF ICNTYP(IPMAX)
C =2).  NOTE THAT HERE ICNTYP(IPMAX) MUST BE 1 OR 2 SINCE ERCMP1
C COMPUTED IPMAX AS THE INDEX OF THE PRIMARY CONSTRAINT WHERE THE
C MAXIMUM PRIMARY CONSTRAINT ERROR (I.E. VALUE) WAS ACHIEVED.
 1100 IF(ICNTYP(IPMAX)-1)1200,1200,1300
 1200 EIPMAX=ERROR(IPMAX)
      GO TO 1400
 1300 EIPMAX=ABS(ERROR(IPMAX))
C
C SET THE PROSPECTIVE NEW RCHDWN.  NOTE THAT WITHOUT THE FUDGE FACTOR,
C RCHD1 WOULD HAVE JUST BARELY BEEN LARGE ENOUGH TO HAVE CAUSED
C CONSTRAINT IPMAX TO BE DECLARED ACTIVE WHEN THE OLD ACTIVE SET WAS
C DETERMINED.  (NOTE THAT RCHDWN MAY HAVE ALREADY BEEN INCREASED
C SINCE THEN.)
 1400 RCHD1=FUDGE*(ENORM-EIPMAX)/UNIT
C
C IF RCHD1 .GT. RCHDWN WE REPLACE RCHDWN BY MIN (RCHD1, RCHTOP).
      IF(RCHD1-RCHDWN)2700,2700,1500
 1500 RCHDWN=RCHD1
      IF(RCHDWN-RCHTOP)1700,1700,1600
 1600 RCHDWN=RCHTOP
 1700 CONTINUE
C1700 WRITE(NWRIT,1800)RCHDWN
C1800 FORMAT(23H ***RCHDWN INCREASED TO,E24.14)
      RETURN
C
C
C HERE IRCH=-1 AND WE CONSIDER CHANGING RCHIN.
C
C SEE IF CONSTRAINT ISMAX IS IN THE ACTIVE SET, AND RETURN IF IT IS.
C NOTE THAT ISMAX .GT. 0 SINCE WE WOULD NOT HAVE CALLED RCHMOD WITH
C IRCH=-1 IF THERE WERE NO STANDARD CONSTRAINTS.
 2000 DO 2100 L=1,MACT
        I=IABS(IACT(L))
        IF(I-ISMAX)2100,2700,2100
 2100   CONTINUE
C
C RETURN IF RCHIN .GE. RCHTOP.
      IF(RCHIN-RCHTOP)2200,2700,2700
C
C SET THE PROSPECTIVE NEW RCHIN.  NOTE THAT WITHOUT THE FUDGE FACTOR,
C RCH1 WOULD HAVE BEEN JUST BARELY LARGE ENOUGH TO HAVE CAUSED
C CONSTRAINT ISMAX TO BE DECLARED ACTIVE WHEN THE OLD ACTIVE SET WAS
C DETERMINED.  (NOTE THAT RCHIN MAY HAVE ALREADY BEEN INCREASED SINCE
C THEN.  NOTE ALSO THAT ERROR(ISMAX) .LT. 0.0, ELSE CONSTRAINT ISMAX
C WOULD HAVE BEEN DECLARED ACTIVE.)
 2200 RCH1=FUDGE*(-ERROR(ISMAX))/UNIT
C
C IF RCH1 .GT. RCHIN WE REPLACE RCHIN BY MIN(RICH1,RCHTOP).
      IF(RCH1-RCHIN)2700,2700,2300
 2300 RCHIN=RCH1
      IF(RCHIN-RCHTOP)2500,2500,2400
 2400 RCHIN=RCHTOP
 2500 CONTINUE
C2500 WRITE(NWRIT,2600)RCHIN
C2600 FORMAT(22H ***RCHIN INCREASED TO,E24.14)
C
 2700 RETURN
      END
      SUBROUTINE WOLFE(NDM,M,PMAT,ISTRT,S,NCOR,ICOR,IWORK,LIWRK,WORK,
     *LWRK,R,COEF,PTNR,PMAT1,NPARM,NUMGR,WCOEF,WPT,WDIST,NMAJ,NMIN,
     *JFLAG)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PMAT(NPARM+1,NUMGR),ICOR(NPARM+1),WCOEF(NUMGR),
     *WPT(NPARM),R(NPARM+1),COEF(NUMGR),PTNR(NPARM+1),
     *PMAT1(NPARM+1,NUMGR),IWORK(LIWRK),WORK(LWRK)
C
C THIS PROGRAM WAS DEVELOPED BY ED KAUFMAN, DAVID LEEMING, AND JERRY
C TAYLOR.  THE METHOD USED IS AN ENHANCED VERSION OF THE METHOD DESCRIBED
C IN (WOLFE, PHILIP, FINDING THE NEAREST POINT IN A POLYTOPE, MATHEMATICAL
C PROGRAMMING 11 (1976), 128-149).
C
C***THE NEXT GROUP OF COMMENTS IS FOR THE CASE WHERE THE USER WISHES TO
C RUN WOLFE BY ITSELF RATHER THAN AS A PART OF CONMAX.
C
C TO RUN THE PROGRAM, FIRST SET THE THREE MACHINE AND PRECISION DEPENDENT
C CONSTANTS IN FUNCTION SUBPROGRAMS I1MACH AND D1MACH, WRITE A DRIVER
C PROGRAM WHICH DIMENSIONS THE ARRAYS IN THE CALLING SEQUENCE FOR WOLFE
C AND SETS THE INPUT VARIABLES AS SPECIFIED IN THE LIST BELOW, THEN CALL
C SUBROUTINE WOLFE.  THE ONLY SUBPROGRAMS NEEDED ARE I1MACH, D1MACH,
C WOLFE, ILOC, CONENR, HOUSE, DOTPRD, AND REFWL.  NO SUBROUTINE LIBRARIES
C (SUCH AS IMSL) ARE NEEDED.
C
C THE VARIABLES, IN THE ORDER OF THEIR APPEARANCE IN THE ARGUMENT LIST OF
C SUBROUTINE WOLFE, ARE AS FOLLOWS.
C
C NDM  (INPUT)  THIS IS THE NUMBER OF VARIABLES.  IT MUST BE LESS THAN OR
C    EQUAL TO NPARM.
C
C M  (INPUT)  THIS IS THE NUMBER OF INEQUALITIES DEFINING THE POLYTOPE.  IT
C    MUST BE LESS THAN OR EQUAL TO NUMGR.
C
C PMAT  (INPUT)  THIS IS AN ARRAY WHOSE KTH COLUMN CONTAINS THE VECTOR
C    (A(K),B(K)) FOR K=1,...,M, WHERE THE M INEQUALITIES A(K).X + B(K)
C    .LE. 0.0 DEFINE THE POLYTOPE WHOSE NEAREST POINT TO THE ORIGIN WE
C    SEEK.  THE FIRST DIMENSION OF PMAT IN THE DRIVER PROGRAM MUST BE
C    EXACTLY NPARM+1, WHILE THE SECOND DIMENSION OF PMAT IN THE DRIVER
C    PROGRAM MUST BE AT LEAST NUMGR.
C    IF WE ACTUALLY WANT THE NEAREST POINT IN THE POLYTOPE TO SOME POINT
C    Y OTHER THAN THE ORIGIN, WE TRANSLATE Y TO THE ORIGIN BEFORE CALLING
C    WOLFE, THAT IS, CALL WOLFE TO FIND THE NEAREST POINT Z TO THE ORIGIN
C    IN THE POLYTOPE DEFINED BY A(K).Z + (B(K) + A(K).Y) .LE. 0.0, THEN
C    COMPUTE X = Y + Z.
C
C ISTRT  (INPUT)  SET THIS EQUAL TO ZERO UNLESS A HOT START IS DESIRED--
C    SEE NEXT PARAGRAPH OF COMMENTS FOR MORE DETAILS.  IF ISTRT IS SET
C    EQUAL TO 1, THEN S, WCOEF, NCOR, AND ICOR MUST ALSO BE ASSIGNED
C    VALUES INITIALLY.
C
C S  (OUTPUT)  YOU MAY IGNORE THIS SCALE FACTOR UNLESS YOU WANT TO USE
C    THE HOT START OPTION.
C
C NCOR  (OUTPUT)  THIS IS THE NUMBER OF VECTORS (I.E. COLUNNS OF PMAT) IN
C    THE FINAL CORRAL.
C
C ICOR  (OUTPUT)  THIS ARRAY CONTAINS THE NCOR INDICES OF THE VECTORS IN
C    THE FINAL CORRAL.  ITS DIMENSION IN THE DRIVER PROGRAM MUST BE AT
C    LEAST NPARM+1.
C
C IWORK  (WORK ARRAY)  ITS DIMENSION IN THE DRIVER PROGRAM MUST BE LIWRK.
C
C LIWRK  (INPUT)  THIS IS THE DIMENSION OF IWORK.  IT MUST BE AT LEAST
C    7*NPARM + 7*NUMGR + 3.
C
C WORK  (WORK ARRAY)  ITS DIMENSION IN THE DRIVER PROGRAM MUST BE LWRK.
C
C LWRK  (INPUT)  THIS IS THE DIMENSION OF WORK.  IT MUST BE AT LEAST
C    2*NPARM**2 + 4*NUMGR*NPARM + 11*NUMGR + 27*NPARM + 13.
C    NOTE THAT SOME STORAGE COULD BE SAVED BY REWRITING FUNCTION
C    SUBPROGRAM ILOC TO TAKE OUT ALL BUT THE ARRAYS NEEDED (NAMELY 1, 3,
C    4, 9, 28, 32, 34, 39 FOR WORK, 18, 23 FOR IWORK) AND SCRUNCHING
C    WORK AND IWORK IN ILOC SO THE REMAINING ARRAYS FOLLOW ONE AFTER
C    ANOTHER.
C
C R  (WORK ARRAY)  ITS DIMENSION IN THE DRIVER PROGRAM MUST BE AT LEAST
C    NPARM+1.
C
C COEF  (WORK ARRAY)  ITS DIMENSION IN THE DRIVER PROGRAM MUST BE AT LEAST
C    NUMGR.
C
C PTNR  (WORK ARRAY)  ITS DIMENSION IN THE DRIVER PROGRAM MUST BE AT LEAST
C    NPARM+1.
C
C PMAT1  (WORK ARRAY)  ITS DIMENSION IN THE DRIVER PROGRAM SHOULD BE THE
C    SAME AS THE DIMENSION OF PMAT.
C
C NPARM  (INPUT)  THIS IS BASICALLY A DIMENSION PARAMETER HERE.  IT MUST
C    BE GREATER THAN OR EQUAL TO NDM.
C
C NUMGR  (INPUT)  THIS IS BASICALLY A DIMENSION PARAMETER HERE.  IT MUST
C    BE GREATER THAN OR EQUAL TO M.
C
C WCOEF  (OUTPUT)  THIS WILL GIVE THE COEFFICIENTS OF THE VECTORS A(K)
C    NEEDED TO FORM A LINEAR COMBINATION EQUAL TO THE SOLUTION IN WPT.
C    ITS DIMENSION IN THE DRIVER PROGRAM MUST BE AT LEAST NUMGR.
C    WCOEF MAY NOT BE ACCURATE IF IT WAS NECESSARY TO CALL REFWL TO
C    REFINE WPT, WHICH RARELY HAPPENS.
C
C WPT  (OUTPUT)  THIS WILL GIVE THE COORDINATES OF THE POINT WE ARE SEEKING,
C    NAMELY THE NEAREST POINT IN THE POLYTOPE TO THE ORIGIN.  ITS DIMENSION
C    IN THE DRIVER PROGRAM MUST BE AT LEAST NPARM.
C
C WDIST  (OUTPUT)  THIS WILL BE THE (MINIMIZED) EUCLIDEAN DISTANCE OF WPT
C    FROM THE ORIGIN.
C
C NMAJ  (OUTPUT)  THIS WILL BE THE NUMBER OF MAJOR CYCLES USED IN WOLFE.
C
C NMIN  (OUTPUT)  THIS WILL BE THE NUMBER OF MINOR CYCLES USED IN WOLFE.
C
C JFLAG  (OUTPUT)  THIS IS A FLAG VARIABLE WHICH IS 0 IN CASE OF A NORMAL
C    SOLUTION AND IS POSITIVE OTHERWISE (IN WHICH CASE THE RETURNED
C    SOLUTION MAY BE NO GOOD).
C
C***END OF COMMENTS FOR RUNNING WOLFE BY ITSELF RATHER THAN AS A PART OF
C CONMAX.
C
C GIVEN M INEQUALITIES OF THE FORM A(K).X + B(K) .LE. 0.0 FOR K=1,
C ...,M, WHERE A(K) AND X ARE NDM DIMENSIONAL VECTORS AND B(K)
C ARE NUMBERS, THIS SUBROUTINE RETURNS THE NEAREST POINT TO THE
C ORIGIN IN THE POLYTOPE DEFINED BY THESE INEQUALITIES (UNLESS
C JFLAG .GT. 0, WHICH INDICATES FAILURE).  THE USER SHOULD PUT
C THE MDM+1 DIMENSIONAL VECTORS (A(K),B(K)) IN THE COLUMNS OF PMAT.
C THE SOLUTION POINT WILL BE RETURNED IN WPT, AND WILL ALSO BE A
C LINEAR COMBINATION OF THE A(K) VECTORS WITH (NONPOSITIVE)
C COEFFICIENTS IN THE M DIMENSIONAL VECTOR WCOEF.  WCOEF MAY NOT BE
C ACCURATE IF REFWL WAS USED TO REFINE WPT, WHICH RARELY HAPPENS. THE
C NUMBER OF VECTORS IN THE FINAL CORRAL WILL BE RETURNED IN NCOR WITH
C THEIR INDICES IN ICOR, AND ALL ENTRIES OF WCOEF NOT CORRESPONDING TO
C INDICES IN ICOR WILL BE ZERO.  THE DISTANCE WILL BE RETURNED IN
C WDIST, AND THE NUMBERS OF MAJOR AND MINOR CYCLES IN THE CONE
C SUBPROBLEM WILL BE RETURNED IN NMAJ AND NMIN RESPECTIVELY.
C IF THE USER SETS ISTRT=0 THE PROGRAM WILL START FROM SCRATCH, BUT
C THE USER CAN SET ISTRT=1 (HOT START) AND SPECIFY NCOR, ICOR, WCOEF,
C AND THE FACTOR S.  (SEE LATER COMMENTS; SET S=1.0 IF NO BETTER VALUE IS
C AVAILABLE.  SET WCOEF(J)=0.0 IF ICOR(I) .NE. J FOR I=1,...,NCOR.)  (IF
C INACCURATE WCOEF OR S IS USED IN A HOT START ATTEMPT LITTLE WILL BE
C LOST, SINCE NCOR AND ICOR ARE MORE IMPORTANT FOR A SUCCESSFUL HOT START
C THAN WCOEF AND S.)  WE MUST ALWAYS HAVE NCOR .LE. NDM+1 IN THEORY SINCE
C THE NCOR NDM+1 DIMENSIONAL VECTORS IN A CORRAL SHOULD BE LINEARLY
C INDEPENDENT, AND IN PRACTICE WE WILL ALWAYS REQUIRE NCOR .LE. NDM+1.
C IF THE USER SETS ISTRT=1 BUT THE PROGRAM FAILS, IT WILL
C AUTOMATICALLY TRY FROM SCRATCH BEFORE GIVING UP.
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR WOLFE.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      THREE=ONE+TWO
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      TOL=TEN*TEN*SPCMN
      TOL1=(TEN**4)*SPCMN
      TOLS=SQRT(SPCMN)
      IREF=0
      VIOLM=ONE/TWO
      LMCON=3
      ITCON=0
      IUP=0
      S1LOW=TEN*TEN*TEN*SPCMN
      S1HI=ONE-S1LOW
C MAKE SURE S1LOW .LE. ONE THIRD AND S1HI .GE. TWO THIRDS TO AVOID
C SQUEEZING THE ALLOWABLE REGION FOR S1 TOO TIGHTLY (OR EVEN MAKING IT
C EMPTY).
      IF(S1LOW-ONE/THREE)40,40,30
  30  S1LOW=ONE/THREE
  40  IF(S1HI-TWO/THREE)50,60,60
  50  S1HI=TWO/THREE
  60  FACSC=TEN*TEN*TEN*TEN
      FACKP=FACSC
C END OF SETTING MACHINE AND PRECISION DEPENDENT CONSTANTS FOR WOLFE.
      ILC18=ILOC(18,NPARM,NUMGR)
      ILC28=ILOC(28,NPARM,NUMGR)
      ILC32=ILOC(32,NPARM,NUMGR)
      ILC34=ILOC(34,NPARM,NUMGR)
      ILC39=ILOC(39,NPARM,NUMGR)
      N=NDM+1
      ISTRT1=ISTRT
      DO 100 I=1,NDM
        R(I)=ZERO
  100   CONTINUE
      R(N)=ONE
C
C NOW COMPUTE THE SCALE FACTOR SCL, WHOSE MAIN PURPOSE IS TO AVOID
C HAVING ALL VECTORS IN PMAT WITH POSITIVE LAST COMPONENT FORM AN ANGLE
C CLOSE TO 90 DEGREES WITH R = (0...0 1), WHICH CAN CAUSE NUMERICAL
C PROBLEMS.  WE WILL COMPUTE SCL = MIN(MAX(ABS(A(I,K)): 1 .LE. I .LE.
C NDM)/B(K), B(K) .GE. TOLS, 1 .LE. K .LE. M) UNLESS NO B(K) IS .GE.
C TOLS, IN WHICH CASE WE SET SCL=1.0, OR SOME B(K) IS .GE. TOLS BUT
C SCL WOULD BE .LT. TOL, IN WHICH CASE WE SET SCL = TOL.
  105 SCL=ONE
      IND=0
      DO 150 K=1,M
        BK=PMAT(N,K)
        IF(BK-TOLS)150,110,110
  110   QUOT=ZERO
        DO 120 I=1,NDM
          AB=ABS(PMAT(I,K))
          IF(AB-QUOT)120,120,115
  115     QUOT=AB
  120     CONTINUE
        QUOT=QUOT/BK
        IF(IND)140,140,130
  130   IF(QUOT-SCL)140,150,150
  140   IND=1
        SCL=QUOT
  150   CONTINUE
  155 IF(SCL-TOL)160,170,170
  160 SCL=TOL
C PUT SCALED PMAT INTO PMAT1 FOR USE IN CONENR.  PMAT ITSELF WILL REMAIN
C UNCHANGED.
  170 DO 180 J=1,M
        DO 175 I=1,NDM
          PMAT1(I,J)=PMAT(I,J)/SCL
  175     CONTINUE
        PMAT1(N,J)=PMAT(N,J)
  180   CONTINUE
C NOW DO A NORMAL SCALING ON EACH COLUMN OF PMAT1 WHICH HAS AN ELEMENT
C WITH ABSOLUTE VALUE .GE. TOL1.
      DO 190 J=1,M
        SCL1=ZERO
        DO 184 I=1,N
          AB=ABS(PMAT1(I,J))
          IF(AB-SCL1)184,184,182
  182     SCL1=AB
  184     CONTINUE
        IF(SCL1-TOL1)185,187,187
C ALSO PUT A SCALED VERSION OF WCOEF INTO COEF IF ISTRT1=1.
  185   IF(ISTRT1)190,190,186
  186   COEF(J)=WCOEF(J)
        GO TO 190
  187   DO 188 I=1,N
          PMAT1(I,J)=PMAT1(I,J)/SCL1
  188     CONTINUE
        IF(ISTRT1)190,190,189
  189   COEF(J)=WCOEF(J)*SCL1
  190   CONTINUE
C
C IF ISTRT1=1, FOR USE IN CONENR SET COEF = (-S1*SCL**2)*COEF, WHERE
C S1 = S/(S + (1.0-S)*SCL**2) IS THE S VALUE IN THE SCALED SITUATION.
C NOTE THAT A PARTLY SCALED VERSION OF WCOEF (SEE LOOP ENDING WITH THE
C STATEMENT NUMBERED 190 ABOVE) IS ALREADY IN COEF IF ISTRT1=1.
      IF(ISTRT1)400,400,200
C IF WE HAD NCOR .GT. N, RESET NCOR TO N.
  200 IF(NCOR-N)275,275,225
  225 NCOR=N
  275 FACT=-(S/(S+(ONE-S)*SCL**2))*SCL**2
      DO 300 J=1,M
        COEF(J)=FACT*COEF(J)
  300   CONTINUE
C
C CALL CONENR TO COMPUTE THE NEAREST POINT TO R IN THE CONE OF
C NONNEGATIVE LINEAR COMBINATIONS OF COLUMNS OF PMAT1.
  400 CALL CONENR(N,M,PMAT1,R,ISTRT1,NCOR,ICOR,TOL,IWORK,LIWRK,
     *WORK,LWRK,WORK(ILC39),WORK(ILC32),WORK(ILC28),NPARM,NUMGR,COEF,
     *PTNR,DIST,NMAJ,NMIN,JFLAG)
C
C IF JFLAG=3 THEN CONENR HAS FAILED, POSSIBLY BECAUSE SCL WAS TOO LARGE.
      IF(JFLAG-3)420,440,420
C HERE JFLAG .NE. 3 AND WE COMPUTE S1 = 1.0 - PTNR(N).
  420 S1=ONE-PTNR(N)
      IF(S1-S1LOW)440,580,580
C HERE JFLAG=3 OR S1 .LT. S1LOW, SO IF ITCON .LT. LMCON WE TRY AGAIN WITH
C SMALLER SCL.
  440 IF(ITCON-LMCON)480,460,460
C
C HERE WE WERE UNABLE TO GET AN ACCEPTABLE S1 FROM CONENR SO WE SET
C JFLAG=4 AS A WARNING AND RETURN.  FIRST TRY AGAIN FROM SCRATCH IF THIS
C HAS NOT BEEN DONE.
  460 IF(ISTRT1)470,470,465
  465 ISTRT1=0
      ITCON=0
      IREF=0
      IUP=0
      FACSC=FACKP
      GO TO 105
C
  470 JFLAG=4
      RETURN
C
C HERE WE INCREMENT ITCON AND IF SCL WAS NOT ALREADY VERY SMALL WE
C DECREASE IT AND TRY CONENR AGAIN.
  480 ITCON=ITCON+1
      IF(IUP)540,520,500
C HERE IUP=1 AND WE HAVE OSCILLATION IN THE SEARCH FOR A USABLE SCL SO
C WE REPLACE THE CORRECTION FACTOR BY ITS SQUARE ROOT AND RESET IUP TO
C 0 TO INDICATE OSCILLATION.
  500 IUP=0
  510 FACSC=SQRT(FACSC)
      GO TO 540
C
C HERE IUP=0 SO EITHER WE ARE JUST STARTING (IN WHICH CASE WE SET IUP=-1
C TO INDICATE WE ARE IN A PHASE OF DECREASING SCL) OR WE ARE OSCILLATING.
  520 IF(ITCON-1)530,530,510
  530 IUP=-1
C HERE WE DECREASE SCL IF IT WAS NOT ALREADY VERY SMALL.
  540 IF(SCL-(ONE+ONE/TEN)*TOL)460,560,560
  560 SCL=SCL/FACSC
      GO TO 155
C
C HERE JFLAG .NE. 3 AND S1 .GE. S1LOW, SO IF ALSO S1 .LE. S1HI WE ACCEPT
C THE RESULT FROM CONENR AND MOVE ON.
  580 IF(S1-S1HI)680,680,600
C
C HERE JFLAG .NE. 3 AND S1 .GT. S1HI, SO IF ITCON .LT. LMCON WE TRY
C AGAIN WITH LARGER SCL.
C IF HERE JFLAG=0 AND NCOR=0 THE NEAREST POINT TO THE ORIGIN IN THE
C POLYTOPE APPEARS TO BE THE ORIGIN SO WE FOREGO ADJUSTING SCL.
  600 IF(JFLAG)608,603,608
  603 IF(NCOR)680,680,608
  608 IF(ITCON-LMCON)610,460,460
  610 ITCON=ITCON+1
      IF(IUP)620,640,660
C HERE IUP=-1 AND WE HAVE OSCILLATION IN THE SEARCH FOR A USABLE SCL SO
C WE REPLACE THE CORRECTION FACTOR BY ITS SQUARE ROOT AND SET IUP=0
C TO INDICATE OSCILLATION.
  620 IUP=0
  630 FACSC=SQRT(FACSC)
      GO TO 660
C HERE IUP=0 SO EITHER WE ARE JUST STARTING (IN WHICH CASE WE SET IUP=1
C TO INDICATE WE ARE IN A PHASE OF INCREASING SCL) OR WE ARE OSCILLATING.
  640 IF(ITCON-1)650,650,630
  650 IUP=1
  660 SCL=SCL*FACSC
      GO TO 170
C
C HERE CONENR MAY HAVE SUCCEEDED AND WE COMPUTE THE NEAREST POINT
C (WPT,S1)=R-PTNR TO R FROM THE DUAL OF THE CONE DESCRIBED EARLIER.
C THIS NEW CONE IS THE SET OF (X,T) SUCH THAT (A(K)/SCL,B(K)).(X,T) .LE.
C 0.0 FOR K=1,...,M.
  680 DO 700 I=1,NDM
        WPT(I)=-PTNR(I)
  700   CONTINUE
C DIVIDE WPT BY S1*SCL.
      DO 1000 I=1,NDM
        WPT(I)=WPT(I)/(S1*SCL)
 1000   CONTINUE
C COMPUTE THE MAXIMUM WOLFE CONSTRAINT VIOLATION AS A CHECK.
 1010 DO 1080 J=1,M
        V1=PMAT(N,J)
        DO 1020 I=1,NDM
          V1=V1+PMAT(I,J)*WPT(I)
 1020     CONTINUE
        IF(J-1)1060,1060,1040
 1040   IF(V1-VMAX)1080,1080,1060
 1060   JMAX=J
        VMAX=V1
 1080   CONTINUE
C IF VMAX .LE. VIOLM WE RESET JFLAG TO 0 AND ACCEPT THE RESULT.
      IF(VMAX-VIOLM)1082,1082,1084
 1082 JFLAG=0
      GO TO 1099
C
C HERE VMAX IS TOO LARGE.
 1084 IF(IREF)1094,1094,1086
C HERE WE HAVE UNSUCCESSFULLY TRIED TO REFINE WPT WITH REFWL AT LEAST
C ONCE.  IF NCOR .LT. NDM AND THE WORST VIOLATION OCCURRED OUTSIDE
C ICOR WE WILL PUT IT IN ICOR AND TRY REFWL AGAIN, OTHERWISE WE WILL
C SET JFLAG=7 AND RETURN (FIRST TRYING FROOM SCRATCH IF THIS HAS NOT
C BEEN DONE).
 1086 IF(NCOR-NDM)1088,1096,1096
 1088 IF(NCOR)1093,1093,1090
 1090 DO 1092 L=1,NCOR
        IF(JMAX-ICOR(L))1092,1096,1092
 1092   CONTINUE
 1093 NCOR=NCOR+1
      ICOR(NCOR)=JMAX
C
C INCREMENT IREF AND CALL REFWL TO ATTEMPT TO REFINE WPT, THEN GO BACK
C AND RECHECK THE MAXIMUM CONSTRAINT VIOLATION.
 1094 IREF=IREF+1
      CALL REFWL(NDM,NCOR,ICOR,PMAT,PMAT1,NPARM,NUMGR,IWORK(ILC18),
     *WORK(ILC34),WPT)
      GO TO 1010
C
 1096 IF(ISTRT1)1098,1098,1097
 1097 ISTRT1=0
      ITCON=0
      IREF=0
      IUP=0
      FACSC=FACKP
      GO TO 105
C
 1098 JFLAG=7
      RETURN
C
C DIVIDE THE COEFFICIENTS BY -S1*SCL**2.
 1099 DO 1100 J=1,M
        WCOEF(J)=-COEF(J)/(S1*SCL**2)
 1100   CONTINUE
C
C WE NOW RECONSTRUCT THE NORMAL SCALING FACTORS COMPUTED IN THE LOOP
C ENDING WITH THE STATEMENT LABELLED 190 IN THIS SUBROUTINE.  IN A LATER
C VERSION OF THIS SUBROUTINE AN ARRAY MAY BE CREATED TO STORE THESE IN
C THAT LOOP, BUT FOR NOW WE AVOID THE EXTRA STORAGE AND PROGRAMMING WORK
C OF FIDDLING WITH THE VARIABLE DIMENSIONING.  TO RECREATE THE FACTOR
C SCL1 CORRESPONDING TO COLUMN J, WE COMPUTE THE MAXIMUM ABSOLUTE VALUE
C OF THE FIRST NDM ELEMENTS OF PMAT IN THIS COLUMN, DIVIDE IT BY SCL, TAKE
C THE MAXIMUM OF THIS AND ABS(PMAT(NDM+1,J)), AND TAKE SCL1 TO BE THIS
C VALUE UNLESS IT IS LESS THAN TOL1, IN WHICH WE (IN EFFECT) TAKE SCL1=1.0.
C FINALLY, SINCE WCOEF(J) WAS COMPUTED WITH THE JTH COLUMN OF PMAT DIVIDED
C BY SCL1 IT CONTAINS A HIDDEN FACTOR OF SCL1, WHICH WE DIVIDE OUT.
      DO 1170 J=1,M
        SCL1A=ZERO
        DO 1130 I=1,NDM
          AB=ABS(PMAT(I,J))
          IF(AB-SCL1A)1130,1130,1120
 1120     SCL1A=AB
 1130     CONTINUE
        SCL1=SCL1A/SCL
        AB=ABS(PMAT(NDM+1,J))
        IF(AB-SCL1)1150,1150,1140
 1140   SCL1=AB
 1150   IF(SCL1-TOL1)1170,1160,1160
 1160   WCOEF(J)=WCOEF(J)/SCL1
 1170   CONTINUE
C
C COMPUTE THE S VALUE FOR THE UNSCALED SITUATION.
      S=S1/(S1+(ONE-S1)/SCL**2)
C COPY WPT INTO PTNR TO GET THE RIGHT DIMENSION FOR DOTPRD AND COMPUTE
C THE DISTANCE.
      DO 1200 I=1,NDM
        PTNR(I)=WPT(I)
 1200   CONTINUE
      PTNR(N)=ZERO
      WDIST=SQRT(DOTPRD(NDM,PTNR,PTNR,NPARM))
      RETURN
      END
      SUBROUTINE CONENR(N,M,PMAT1,R,ISTRT1,NCOR,ICOR,TOL,IWORK,
     *LIWRK,WORK,LWRK,VEC,PTNRR,PICOR,NPARM,NUMGR,COEF,PTNR,DIST,NMAJ,
     *NMIN,JFLAG)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION PMAT1(NPARM+1,NUMGR),R(NPARM+1),ICOR(NPARM+1),
     *COEF(NUMGR),PTNR(NPARM+1),VEC(NPARM+1),PTNRR(NPARM+1),
     *PICOR(NPARM+1,NPARM+1),IWORK(LIWRK),WORK(LWRK)
C
C GIVEN M N-DIMENSIONAL VECTORS P(J) AS THE FIRST M COLUMNS
C OF THE MATRIX PMAT1 AND AN N-VECTOR R, THIS SUBROUTINE RETURNS IN
C PTNR THE NEAREST POINT TO R IN THE CONE OF POINTS SUMMATION(
C COEF(J)*P(J)), WHERE COEF(J) .GE. 0.0 FOR J=1,...,M (UNLESS JFLAG
C .GT. 0, WHICH INDICATES FAILURE).  THE NUMBER OF VECTORS P(J) IN
C THE FINAL CORRAL IS RETURNED IN NCOR WITH THEIR INDICES IN ICOR,
C THE DISTANCE IS RETURNED IN DIST, THE NUMBER OF MAJOR CYCLES (I.E.
C ADDING A VECTOR) IS RETURNED IN NMAJ, AND THE NUMBER OF MINOR CYCLES
C (I.E. REMOVING A VECTOR) IS RETURNED IN NMIN.  IF THE USER SETS
C ISTRT1=0 THE SUBROUTNE STARTS FROM SCRATCH, BUT THE USER CAN SET
C ISTRT1=1 AND INITIALLY SPECIFY NCOR, ICOR, AND COEF (NOTING THAT NCOR
C MUST BE .LE. N, AND IF J DOES NOT OCCUR IN ICOR, THEN COEF(J) SHOULD
C BE SET TO 0.0.)
C
C SET MACHINE AND PRECISION DEPENDENT CONSTANTS FOR CONENR.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      TOLEL=TEN*TEN*SPCMN
      Z1=TEN*TOLEL
      Z2=TEN*Z1
      Z3=TEN*Z1
C END OF SETTING MACHINE AND PRECISION DEPENDENT CONSTANTS FOR CONENR.
      ILC01=ILOC(1,NPARM,NUMGR)
      ILC03=ILOC(3,NPARM,NUMGR)
      ILC04=ILOC(4,NPARM,NUMGR)
      ILC09=ILOC(9,NPARM,NUMGR)
      ILC23=ILOC(23,NPARM,NUMGR)
      ILC34=ILOC(34,NPARM,NUMGR)
      KNTSL=0
      LIMSL=100
      MP1=M+1
      NDM=N-1
      NMAJ=0
      NMIN=0
      JFLAG=0
      ITST1=0
      NCORO=-1
      IF(ISTRT1)100,100,1000
C
C HERE ISTRT1=0 SO WE START FROM SCRATCH.  FIND THE INDEX JMAX FOR
C WHICH (P(J).R)/SQRT(P(J).P(J)) IS MAXIMIZED FOR P(J).P(J) .GT. Z1.
  100 AMAX=ZERO
      JMAX=0
      DO 500 J=1,M
        DO 200 I=1,N
          VEC(I)=PMAT1(I,J)
  200     CONTINUE
        PDOTJ=DOTPRD(N,VEC,VEC,NPARM)
        IF(PDOTJ-Z1)500,500,300
  300   QUOT=DOTPRD(N,VEC,R,NPARM)/SQRT(PDOTJ)
        IF(QUOT-AMAX)500,500,400
  400   AMAX=QUOT
        JMAX=J
  500   CONTINUE
      IF(JMAX)600,600,550
C IF AMAX IS NOT SIGINFICANTLY POSITIVE WE PROCEED AS IF IT WERE ZERO.
  550 IF(AMAX*SQRT(NDM+ONE)-TOLEL)600,600,800
C
C HERE THERE WERE NO VECTORS P(J) WHICH HAVE BOTH LENGTH SQUARED
C GREATER THAN Z1 AND ANGLE WITH R SIGNIFICANTLY LESS THAN 90 DEGREES,
C AND WE SET NCOR=0, PTNR=THE ZERO VECTOR, COEF=THE ZERO VECTOR, DIST=
C THE LENGTH OF R, AND WE RETURN.
  600 NCOR=0
      DO 700 I=1,N
        PTNR(I)=ZERO
  700   CONTINUE
      DO 750 J=1,M
        COEF(J)=ZERO
  750   CONTINUE
      DIST=SQRT(DOTPRD(N,R,R,NPARM))
      RETURN
C
C HERE WE FOUND THE RAY CLOSEST TO R AND WE COMPLETE THE
C INITIALIZATION BY SETTING NCOR=1, ICOR(1)=JMAX, AND COEF(JMAX)=1.0
C (WITH ALL OTHER ENTRIES OF COEF EQUAL TO ZERO).
  800 NCOR=1
      ICOR(1)=JMAX
      DO 900 I=1,M
        COEF(I)=ZERO
  900   CONTINUE
      COEF(JMAX)=ONE
C
C
C SET PTNR TO THE CURRENT NEAREST POINT.  FIRST ZERO IT OUT.
 1000 DO 1050 I=1,N
        PTNR(I)=ZERO
 1050   CONTINUE
      IF(NCOR)1330,1330,1100
C HERE NCOR .GT. 0 AND WE SET PTNR=SUMMATION(COEF(J)*P(J)).
 1100 DO 1300 J=1,NCOR
        JJ=ICOR(J)
        CJJ=COEF(JJ)
        DO 1200 I=1,N
          PTNR(I)=PTNR(I)+CJJ*PMAT1(I,JJ)
 1200     CONTINUE
 1300   CONTINUE
C
C PUT PTNR-R INTO PTNRR AND COMPUTE THE DISTANCE FROM PTNR TO R.
 1330 DO 1370 I=1,N
        PTNRR(I)=PTNR(I)-R(I)
 1370   CONTINUE
      DSQ=DOTPRD(N,PTNRR,PTNRR,NPARM)
      DIST=SQRT(DSQ)
C
C NOW CHECK OPTIMALITY.
C FIRST SEE WHETHER THE HYPERPLANE THROUGH PTNR PERPENDICULAR TO
C PTNR-R PASSES THROUGH THE ORIGIN.  IF NCOR=0 THIS WILL
C AUTOMATICALLY BE TRUE SINCE THEN PTNR IS THE ORIGIN.  IF IT IS NOT
C TRUE WE GO DOWN TO SOLVE FOR A NEW NEAREST POINT IN THE SUBSPACE
C DETERMINED BY THE CURRENT ICOR.
 1430 IF(NCOR)2100,2100,1470
 1470 TST=DOTPRD(N,PTNR,PTNRR,NPARM)
      IF(ABS(TST)-Z1)2100,4000,4000
C HERE THE HYPERPLANE ROUGHLY PASSES THROUGH THE ORIGIN, AND WE
C CHECK WHETHER ALL P(J) VECTORS ARE ROUGHLY SEPARATED FROM R BY IT.
C PUT THE MINIMUM OF (PTNR-R).(P(J)-R) IN AMIN AND THE INDEX WHERE IT
C IS ACHIEVED IN JMIN.
 2100 DO 2200 I=1,N
        VEC(I)=PMAT1(I,1)-R(I)
 2200   CONTINUE
      JMIN=1
      AMIN=DOTPRD(N,PTNRR,VEC,NPARM)
      IF(M-1)2700,2700,2300
 2300 DO 2600 J=2,M
        DO 2400 I=1,N
          VEC(I)=PMAT1(I,J)-R(I)
 2400     CONTINUE
        DP=DOTPRD(N,PTNRR,VEC,NPARM)
        IF(DP-AMIN)2500,2600,2600
 2500   AMIN=DP
        JMIN=J
 2600   CONTINUE
C
C FOR TESTING PURPOSES COMPUTE THE MAXIMUM OF THE SQUARES OF THE
C LENGTHS OF THE DISTANCES CONSIDERED.
 2700 DO 2800 I=1,N
        VEC(I)=PMAT1(I,JMIN)-R(I)
 2800   CONTINUE
      DMAX=DOTPRD(N,VEC,VEC,NPARM)
      IF(NCOR)3300,3300,2900
 2900 DO 3200 J=1,NCOR
        JJ=ICOR(J)
        DO 3000 I=1,N
          VEC(I)=PMAT1(I,JJ)-R(I)
 3000     CONTINUE
        DP=DOTPRD(N,VEC,VEC,NPARM)
        IF(DP-DMAX)3200,3200,3100
 3100   DMAX=DP
 3200   CONTINUE
C DO THE TEST.  IF IT IS SUCCESSFUL, THEN WE HAVE (APPROXIMATE)
C OPTIMALITY AND WE RETURN.
 3300 IF(AMIN-DSQ+Z1*DMAX)3500,3400,3400
 3400 RETURN
C
C HERE PTNR IS NOT OPTIMAL.  AS A CHECK AGAINST BLUNDERS WE MAKE SURE
C NCOR .LT. N AND JMIN IS NOT IN ICOR.
 3500 IF(NCOR)3900,3900,3550
 3550 IF(NCOR-N)3600,3800,3800
 3600 DO 3700 L=1,NCOR
        IF(JMIN-ICOR(L))3700,3800,3700
 3700   CONTINUE
      GO TO 3900
C
C HERE WE HAVE BLUNDERED SO WE SET JFLAG=1 AS A WARNING, COMPUTE DIST,
C AND RETURN.  FIRST TRY FROM SCRATCH IF THIS HAS NOT BEEN DONE.
 3800 IF(ISTRT1+JFLAG)3870,3870,3830
 3830 JFLAG=-1
      KNTSL=0
      GO TO 100
 3870 JFLAG=1
C     WRITE(6,3880)
C3880 FORMAT(26H *****JFLAG IS 1 IN CONENR)
      RETURN
C
C HERE PTNR IS NOT OPTIMAL, NCOR .LT. N, AND JMIN IS NOT IN ICOR.
C WE INCREMENT THE MAJOR CYCLE COUNTER AND ADD P(JMIN).
 3900 NMAJ=NMAJ+1
      NCOR=NCOR+1
      ICOR(NCOR)=JMIN
      COEF(JMIN)=ZERO
C
C CHECK TO SEE IF WE HAVE SOLVED THE SYSTEM BELOW LIMSL TIMES ALREADY,
C AND IF SO, SET JFLAG=6 AS A WARNING AND RETURN (BUT
C TRY FROM SCRATCH BEFORE GIVING UP IF THIS HAS NOT ALREADY BEEN DONE).
 4000 IF(KNTSL-LIMSL)4080,4020,4020
 4020 IF(ISTRT1+JFLAG)4060,4060,4040
 4040 JFLAG=-1
      KNTSL=0
      GO TO 100
C
 4060 JFLAG=6
C     WRITE(6,4070)
C4070 FORMAT(26H *****JFLAG IS 6 IN CONENR)
      RETURN
C
C CHECK TO SEE IF NCOR AND THE LAST ELEMENT IN ICOR ARE UNCHANGED FROM THE
C PREVIOUS HOUSE CALL (HA HA), WHICH INDICATES FAILURE.  NOTE THAT HERE WE
C MUST HAVE NCOR .GT. 0.
 4080 IF(NCOR-NCORO)4130,4090,4130
 4090 IF(ICOR(NCOR)-ICORO)4140,4100,4140
C
C HERE WE HAVE CYCLING AND WE SET JFLAG=2 AS A WARNING AND RETURN.  FIRST
C TRY FROM SCRATCH IF THIS HAS NOT BEEN DONE.
 4100 IF(ISTRT1+JFLAG)4120,4120,4110
 4110 JFLAG=-1
      KNTSL=0
      GO TO 100
C
 4120 JFLAG=2
      RETURN
C
 4130 NCORO=NCOR
 4140 ICORO=ICOR(NCOR)
      KNTSL=KNTSL+1
C
C NOW WE SOLVE THE SYSTEM PICOR*VEC = R IN THE LEAST SQUARES
C SENSE FOR THE COEFFICIENT VECTOR VEC (RELATIVE TO
C ICOR) OF THE NEAREST POINT TO R IN THE SUBSPACE SPANNED BY
C P(ICOR(1)),...,P(ICOR(NCOR)), WHERE P(ICOR) IS THE N X NCOR MATRIX
C WHOSE COLUMNS ARE THESE VECTORS.
C NOW FILL IN PICOR AND CALL HOUSE TO COMPUTE VEC.
      DO 4300 J=1,NCOR
        JJ=ICOR(J)
        DO 4200 I=1,N
          PICOR(I,J)=PMAT1(I,JJ)
 4200     CONTINUE
 4300   CONTINUE
C
      CALL HOUSE(N,NCOR,PICOR,R,IWORK(ILC23),NPARM,WORK(ILC01),
     *WORK(ILC04),WORK(ILC09),WORK(ILC34),WORK(ILC03),VEC,IHOUSE)
C
C IF HOUSE FAILS (INDICATED BY IHOUSE=1) WE SET JFLAG=3 AS A
C WARNING AND RETURN.  FIRST TRY FROM SCRATCH IF THIS HAS NOT BEEN DONE.
      IF(IHOUSE)5500,5500,5400
 5400 IF(ISTRT1+JFLAG)5470,5470,5430
 5430 JFLAG=-1
      KNTSL=0
      GO TO 100
C
 5470 JFLAG=3
      RETURN
C
C CHECK TO SEE IF ALL THE COEFFICIENTS IN VEC ARE .GT. Z2, AND IF SO,
C PUT VEC INTO COEF AND GO BACK TO COMPUTE PTNR.  THE COEFFICIENTS IN
C COEF NOT CORRESPONDING TO THOSE IN VEC WILL REMAIN EQUAL TO ZERO.
 5500 DO 5600 I=1,NCOR
        IF(VEC(I)-Z2)5800,5800,5600
 5600   CONTINUE
      DO 5700 I=1,NCOR
        II=ICOR(I)
        COEF(II)=VEC(I)
 5700   CONTINUE
      GO TO 1000
C
C HERE SOME ELEMENT OF VEC IS .LE. Z2.  COMPUTE THETA=MIN(1.0, MIN(
C COEF(ICOR(I))/(COEF(ICOR(I))-VEC(I)): COEF(ICOR(I))-VEC(I) .GT. Z3)).
 5800 THETA=ONE
      DO 6100 L=1,NCOR
        LL=ICOR(L)
        DIFF=COEF(LL)-VEC(L)
        IF(DIFF-Z3)6100,6100,5900
 5900   QUOT=COEF(LL)/DIFF
        IF(QUOT-THETA)6000,6100,6100
 6000   THETA=QUOT
 6100   CONTINUE
C COMPUTE THE NEW COEF AS (1.0-THETA)*COEF+THETA*VEC.
      OMT=ONE-THETA
      DO 6200 L=1,NCOR
        LL=ICOR(L)
        COEF(LL)=OMT*COEF(LL)+THETA*VEC(L)
 6200   CONTINUE
C COMPUTE THE INDEX MINCF (RELATIVE TO ICOR) OF THE SMALLEST ELEMENT OF
C COEF AND SET ALL ELEMENTS OF COEF WHICH ARE .LE. Z2 TO ZERO.
      MINCF=0
      AMIN=Z2
      DO 6600 I=1,NCOR
        II=ICOR(I)
        IF(COEF(II)-Z2)6300,6300,6600
 6300   IF(COEF(II)-AMIN)6400,6400,6500
 6400   AMIN=COEF(II)
        MINCF=I
 6500   COEF(II)=ZERO
 6600   CONTINUE
C
      IF(MINCF)6640,6640,6800
C HERE MINCF=0 AND AN UNLIKELY BLUNDER HAS OCCURRED.  THIS MUST BE DUE TO
C ROUNDOFF ERROR SINCE IN THEORY (NEW) COEF(ICOR(I)) MUST BE .LE. Z2
C FOR SOME I=1,...,NCOR, WHICH MAKES MINCF .GT. 0 IN THE LAST LOOP.
C TO SEE THIS, FIRST NOTE THAT FOR SOME IBAR=1,...,NCOR, VEC(IBAR) MUST
C BE .LE. Z2 SINCE OTHERWISE WE WOULD NOT BE HERE.  BY ITS DEFINITION,
C THETA MUST BE .LE. 1.0.  IF THETA = 1.0, THEN (NEW) COEF(ICOR(IBAR))
C = (1.0 - THETA)*(OLD) COEF(ICOR(IBAR)) + THETA*VEC(IBAR) = VEC(IBAR)
C .LE. Z2.  IF ON THE OTHER HAND THETA .LT. 1.0, THEN FOR SOME ISTAR=1,
C ...,ICOR WE HAVE (OLD) COEF(ICOR(ISTAR)) - VEC(ISTAR) .GE. Z3 AND
C THETA = (OLD) COEF(ICOR(ISTAR))/((OLD) COEF(ICOR(ISTAR)) - VEC(ISTAR)),
C SO (NEW) COEF(ICOR(ISTAR)) = (1.0 - THETA)*(OLD) COEF(ICOR(ISTAR)) +
C THETA*VEC(ISTAR) = (-VEC(ISTAR)*(OLD) COEF(ICOR(ISTAR)) + (OLD)
C COEF(ICOR(ISTAR))*VEC(ISTAR))/((OLD) COEF(ICOR(ISTAR)) - VEC(ISTAR))
C = 0.0.  NOTE THAT WE HAVE Z2 .GE. 0.0 AND Z3 .GT. 0.0.
C TO CORRECT THIS BLUNDER WE SET MINCF = AN INDEX I FOR WHICH (NEW)
C COEF(ICOR(I)) IS MINIMIZED AND SET COEF(ICOR(I)) = 0.0.
 6640 DO 6760 I=1,NCOR
        II=ICOR(I)
        IF(I-1)6720,6720,6680
 6680   IF(COEF(II)-AMIN)6720,6760,6760
 6720   AMIN=COEF(II)
        MINCF=I
 6760   CONTINUE
      II=ICOR(MINCF)
      COEF(II)=ZERO
C
C INCREMENT THE MINOR ITERATION COUNTER NMIN, REMOVE ICOR(MINCF),
C AND DECREMENT NCOR.
 6800 NMIN=NMIN+1
      DO 7000 L=1,NCOR
        IF(L-MINCF)7000,7000,6900
 6900   ICOR(L-1)=ICOR(L)
 7000   CONTINUE
      NCOR=NCOR-1
C GO BACK TO COMPUTE PTNR.
      GO TO 1000
      END
      SUBROUTINE HOUSE(N,NCOR,PICOR,R,KPIVOT,NPARM,AA,BETA,D,SAVE,B,
     *VEC,IHOUSE)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION VEC(NPARM+1),AA(NPARM+1,NPARM+1),BETA(NPARM+1),
     *D(NPARM+1),KPIVOT(NPARM+1),SAVE(NPARM+1),B(NPARM+1),
     *PICOR(NPARM+1,NPARM+1),R(NPARM+1)
C
C GIVEN NCOR N DIMENSIONAL VECTORS AS COLUMNS OF THE N BY NCOR
C MATRIX PICOR AND AN N DIMENSIONAL VECTOR R, THIS SUBROUTINE USES
C HOUSEHOLDER TRANSFORMATIONS TO FIND THE BEST LEAST SQUARES SOLUTION
C VEC TO THE LINEAR SYSTEM OF EQUATIONS PICOR*VEC = R, WHERE VEC
C IS AN NCOR DIMENSIONAL VECTOR.  IF THE RANK OF PICOR IS
C (COMPUTATIONALLY) 0, THE SUBROUTINE WILL RETURN WITH THE FAILURE
C WARNING IHOUSE=1, OTHERWISE IT WILL RETURN WITH IHOUSE=0.  IF THE
C RANK IS .GT. 0 BUT .LT. NCOR, THEN (NCOR - RANK) OF THE COMPONENTS
C OF VEC WILL BE SET TO 0.0.  THE ARAYS PICOR AND R WILL NOT BE
C CHANGED BY THIS SUBROUTINE.  THE SUBROUTINE WILL ATTEMPT UP TO
C NUMREF ITERATIVE REFINEMENTS OF THE SOLUTION, WHERE THE USER CAN
C SET NUMREF AS ANY NONNEGATIVE INTEGER, BUT TO GET THE MOST OUT OF
C THE ITERATIVE REFINEMENT PROCESS, THE COMPUTATION OF THE RESIDUAL
C SUMM NEAR THE END OF THIS SUBROUTINE SHOULD BE DONE IN HIGHER
C PRECISION THAN THE OTHER COMPUTATIONS IN THE SUBROUTINE.
C
C COMPUTE MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      ONE=1.0D0
      ZERO=ONE-ONE
      TWO=ONE+ONE
      FOUR=TWO+TWO
      TEN=FOUR+FOUR+TWO
      SPCMN=D1MACH(3)
      TOLSQ=(TEN*TEN*SPCMN)**2
      IHOUSE=0
C SET NUMREF = THE LIMIT ON THE NUMBER OF ITERATIVE REFINEMENT STEPS.
      NUMREF=1
      NMREF1=NUMREF+1
      NMREF2=NUMREF+2
C SET KRANK = MIN(N,NCOR).  THIS MAY BE REDUCED LATER.
      KRANK=NCOR
      IF(N-NCOR)6,8,8
    6 KRANK=N
C INITIALLY SET KPIVOT.  AFTER ALL COLUMN INTERCHANGES ARE DONE
C KPIVOT(J) WILL BE THE ORIGINAL POSITION OF THE COLUMN WHERE THE
C JTH PIVOT WAS DONE.  THIS COLUMN WILL BE MOVED TO COLUMN J.
    8 DO 10 J=1,NCOR
         KPIVOT(J)=J
   10 CONTINUE
C COPY R INTO B AND PICOR INTO AA, BUT IN THE PROCESS REPLACE ANY NUMBERS
C WITH ABSOLUTE VALUE LESS THAN SPCMN BY ZERO TO AVOID UNDERFLOWS.
      DO 18 I=1,N
        IF(ABS(R(I))-SPCMN)14,16,16
   14   B(I)=ZERO
        GO TO 18
   16   B(I)=R(I)
   18   CONTINUE
      DO 23 J=1,NCOR
        DO 22 I=1,N
          IF(ABS(PICOR(I,J))-SPCMN)20,21,21
   20     AA(I,J)=ZERO
          GO TO 22
   21     AA(I,J)=PICOR(I,J)
   22     CONTINUE
   23   CONTINUE
      DO 130 K=1,NCOR
         IF(K-N)24,24,140
   24    D(K)=ZERO
         KCHNGE=K
         DO 40 JJ=K,NCOR
            SUM=ZERO
            DO 30 IA=K,N
              IF(ABS(AA(IA,JJ))-SPCMN)30,30,25
   25         SUM=SUM+AA(IA,JJ)*AA(IA,JJ)
   30         CONTINUE
            IF(D(K)-SUM)35,40,40
   35       KCHNGE=JJ
            D(K)=SUM
   40    CONTINUE
C
C  KCHNGE CONTAINS THE INDEX OF THE COLUMN OF GREATEST
C  LENGTH BETWEEN K AND NCOR (FROM POSITION K TO THE BOTTOM).
C IF K=1 AND D(K) .LT. TOLSQ WE RETURN WITH THE FAILURE WARNING
C IHOUSE=1.
        IF(K-1)42,42,48
   42   IF(D(K)-TOLSQ)44,48,48
   44   IHOUSE=1
        RETURN
C
   48    IF(KCHNGE-K)49,60,49
C
C  START COLUMN INTERCHANGE.
C
   49    DO 50 I=1,N
            STORE=AA(I,KCHNGE)
            AA(I,KCHNGE)=AA(I,K)
            AA(I,K)=STORE
   50    CONTINUE
         KK=KPIVOT(K)
         KPIVOT(K)=KPIVOT(KCHNGE)
         KPIVOT(KCHNGE)=KK
   60    CONTINUE
         IF(K-1)65,70,65
   65    AMAX=ABS(D(1))
         TEST=(FLOAT(N-K+1)*(TEN*TEN*SPCMN)**2)*(AMAX*AMAX)
         IF(ABS(D(K))-TEST)67,67,70
C
C HERE THE LENGTH OF THE BEST OF COLUMNS K THROUGH NCOR (FROM K DOWN)
C WAS TOO SMALL, AND WE REDUCE KRANK TO K-1 AND LEAVE THIS LOOP.
   67    D(K)=SQRT(D(K))
         KRANK=K-1
         GO TO 140
C
   70    CONTINUE
C
C NOW COMPUTE THE SCALAR BETA(K) AND THE N-K+1 DIMENSIONAL VECTOR
C GNU(K) (TO BE PLACED IN AA(K,K),...,AA(N,K)) FOR I(K) - BETA(K)*
C GNU(K)*(GNU(K) TRANSPOSE), WHICH IS THE ACTIVE PART OF THE
C HOUSEHOLDER TRANSFORMATION PH(K) = DIAG(I(K-1), ACTIVE PART).  THIS
C IS A SYMMETRIC ORTHOGONAL MATRIX WHICH WHEN MULTIPLIED TIMES AA WILL
C ZERO OUT AA(K+1,K),...,AA(N,K) AND CHANGE AA(K,K) TO -SGN(OLD
C AA(K,K))*SQDK, WHERE SQDK = LENGTH OF OLD (AA(K,K),...,AA(N,K)) AND
C WE REDEFINE THE SGN FUNCTION TO HAVE VALUE 1.0 IF ITS ARGUMENT IS
C 0.0.  WE WILL HAVE BETA(K) = 1.0/(SQDK**2 + ABS(OLD AA(K,K))*SQDK)
C AND GNU(K) = (OLD AA(K,K) + SGN(OLD AA(K,K))*SQDK, OLD AA(K+1,K),...,
C OLD AA(N,K)).  WE WILL ALSO REPLACE D(K) BY THE NEW AA(K,K) (WHICH
C WILL NOT ACTUALLY BE WRITTEN INTO AA) FOR LATER USE.
         AAKK=AA(K,K)
         SQDK=SQRT(D(K))
         IF(AAKK-ZERO)80,75,75
   75    BETA(K)=ONE/(D(K)+AAKK*SQDK)
         AA(K,K)=SQDK+AAKK
         D(K)=-SQDK
         GO TO 90
   80    CONTINUE
         BETA(K)=ONE/(D(K)-AAKK*SQDK)
         AA(K,K)=-SQDK+AAKK
         D(K)=SQDK
   90    CONTINUE
         KT=K+1
         IF(K-NCOR)95,120,95
C
C HERE K .LT. NCOR AND WE MULTIPLY COLUMNS K+1,...,NCOR OF AA BY THE
C HOUSEHOLDER TRANSFORMATION PH(K), WHICH WILL CHANGE ONLY POSITIONS
C K THROUGH THE BOTTOM OF THESE COLUMNS.  THIS IS DONE BY, FOR J =
C K+1,...,NCOR, REPLACING COLUMN J (FROM K DOWN) BY COLUMN J (FROM K DOWN)
C - GNU(K)*(GNU(K).COLUMN J (FROM K DOWN))*BETA(K).
   95    DO 110 J=KT,NCOR
            SAVE(J)=ZERO
            DO 100 IA=K,N
  100       SAVE(J)=SAVE(J)+AA(IA,K)*AA(IA,J)
            DO 110 I=K,N
               AA(I,J)=AA(I,J)-AA(I,K)*SAVE(J)*BETA(K)
  110    CONTINUE
  120    CONTINUE
  130 CONTINUE
  140 CONTINUE
C
      DO 150 I=1,KRANK
C IF I .LE. MIN(KRANK,NCOR-1), DIVIDE ROW I OF AA FROM COLUMN I+1
C THROUGH COLUMN NCOR BY THE NEW AA(I,I) (WHICH IS NOT ACTUALLY
C WRITTEN INTO AA(I,I), BUT IS STORED IN D(I)).
         II=I+1
         IF(I-NCOR)145,160,145
  145    DO 150 J=II,NCOR
            AA(I,J)=AA(I,J)/D(I)
  150 CONTINUE
  160 CONTINUE
C
C NOW ALL THE DIAGONAL ELEMENTS OF AA (ALTHOUGH NOT WRITTEN IN)
C ARE 1.0 AND ALL OFF DIAGONAL ELEMENTS OF AA ARE LESS THAN OR
C EQUAL TO 1.0.
C
C INITIALIZE THE ITERATIVE REFINEMENT COUNTER ICOUNT AND ZERO OUT VEC
C INITIALLY.  THE VEC VALUES NOT CORRESPONDING TO THE FIRST KRANK
C COLUMNS (MODULO EARLIER COLUMN INTERCHANGES) WILL REMAIN AT 0.0.
      ICOUNT=1
      DO 250 I=1,NCOR
  250 VEC(I)=ZERO
  260 CONTINUE
C
C PREMULTIPLY B BY THE HOUSEHOLDER TRANSFORMATIONS PH(1),...,
C PH(KRANK).  RECALL THAT GNU(I) IS STILL IN AA(I,I),...,AA(N,I)
C FOR I=1,...,KRANK.
C
      DO 290 I=1,KRANK
         SUM=ZERO
         DO 270 IA=I,N
  270    SUM=SUM+AA(IA,I)*B(IA)
         SUM=SUM*BETA(I)
         DO 280 J=I,N
            B(J)=B(J)-AA(J,I)*SUM
  280    CONTINUE
  290 CONTINUE
C
C NOW ONLY USE THE FIRST KRANK TERMS OF B, AS WE CANT DO ANYTHING ABOUT
C THE OTHERS, WHOSE SQUARE ROOT OF SUM OF SQUARES WILL GIVE THE LEAST
C SQUARES DISTANCE.
C DIVIDE B(I) BY D(I) FOR I=1,...,KRANK AS WE DID THIS TO ROW I OF AA.
C
      DO 300 I=1,KRANK
         B(I)=B(I)/D(I)
  300 CONTINUE
C
C THE PROBLEM HAS NOW BEEN REDUCED TO SOLVING (UPPER LEFT KRANK BY
C KRANK PART OF AA)*(FIRST KRANK TERMS OF VEC, MODULO COLUMN
C INTERCHANGE UNSCRAMBLING) = (FIRST KRANK TERMS OF B).  ALTHOUGH THE
C DIAGONAL AND BELOW DIAGONAL TERMS OF THE COEFFICIENT MATRIX HAVE NOT
C BEEN WRITTEN IN, THE SYSTEM IS UPPER TRIANGULAR WITH DIAGONAL ELEMENTS
C ALL EQUAL TO 1.0, SO WE SOLVE BY BACK SUBSTITUTION.  WE FIRST PUT
C THE SOLUTION TO THIS SYSTEM IN B(1),...,B(KRANK) AND SORT IT OUT
C LATER.  IF ICOUNT .GT. 1 THE SOLUTION IS AN ITERATIVE CORRECTION TO
C VEC RATHER THAN VEC ITSELF.
      DO 320 II=1,KRANK
         I=KRANK+1-II
         KK=I-1
         IF(I-1)305,320,305
C HERE WE ALREADY HAVE B(I) (WHERE I  .GT. 1) AND WE SUBTRACT AA(J,I)*
C B(I) FROM B(J) FOR J = 1,...,I-1.
  305    DO 310 J=1,KK
            B(J)=B(J)-AA(J,I)*B(I)
  310    CONTINUE
  320 CONTINUE
C
C  TEST FOR CONVERGENCE.
C  FIRST TEST, TOO MANY ITERATIONS.
C  SECOND TEST, SEE IF VEC IS DECREASING.
C
C COMPUTE THE LENGTH SQUARED OF THE FIRST TOP 1 THROUGH KRANK PART OF
C B, WHICH WILL BE THE RESIDUAL VECTOR IF ICOUNT .GT. 1.
      SUM=ZERO
      DO 390 I=1,KRANK
        IF(ABS(B(I))-SPCMN)390,390,385
  385   SUM=SUM+B(I)*B(I)
  390   CONTINUE
      IF(ICOUNT-1)395,400,395
  395 IF(SUM-TEST/TWO)410,410,397
  397 ICOUNT=NMREF2
      GO TO 410
  400 TESTT=SUM
  410 TEST=SUM
C
C COMPUTE THE VEC VALUES, WHICH WILL BE ACTUAL VEC VALUES IF ICOUNT=1
C AND CORRECTIONS TO VEC VALUES IF ICOUNT .GT. 1.  WE GET THESE BY
C UNSCRAMBLING THE B VALUES AND ADDING THEM TO THE APPROPRIATE OLD VEC
C VALUES (WHICH WILL BE 0.0 IF ICOUNT=1).
      DO 420 I=1,KRANK
         KP=KPIVOT(I)
         VEC(KP)=B(I)+VEC(KP)
  420 CONTINUE
C
C CALCULATE THE RESIDUAL R - ACOEF*VEC.  RECALL THAT ACOEF AND R
C CONTAIN THE ORIGINAL COEFFICIENT AND RIGHT SIDE ARRAYS RESPECTIVELY.
C TO GET THE MOST OUT OF ITERATIVE REFINEMENT THIS COMPUTATION SHOULD
C PROBABLY BE DONE IN HIGHER PRECISION, IN WHICH CASE IT MAY BE
C FRUITFUL TO ALSO SET NUMREF LARGER AT THE BEGINNING OF THIS
C SUBROUTINE.
      DO 440 I=1,N
         SUMM=ZERO
         DO 430 J=1,NCOR
           IF(ABS(PICOR(I,J))-SPCMN)430,425,425
  425    SUMM=SUMM+PICOR(I,J)*VEC(J)
  430    CONTINUE
  440 B(I)=R(I)-SUMM
C
C  THIRD TEST, WAS THE CORRECTION SIGNIFICANT.
C
      IF(TEST-SPCMN*TESTT)450,442,442
  442 IF(ICOUNT-NMREF1)444,450,444
  444 IF(ICOUNT-NMREF2)446,450,450
  446 ICOUNT=ICOUNT+1
      GO TO 260
  450 CONTINUE
      RETURN
C
      END
      FUNCTION DOTPRD(LGTH,VEC1,VEC2,NPARM)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION VEC1(NPARM+1),VEC2(NPARM+1)
C
C THIS SUBPROGRAM COMPUTES THE DOT PRODUCT OF VECTORS VEC1
C AND VEC2 OF LENGTH LGTH.
C VEC1 AND VEC2 DO NOT APPEAR IN FUNCTION ILOC SINCE THEY ARE USED ONLY
C AS INPUT NAMES FOR THIS SUBPROGRAM, AND SO THEY DON'T NEED TO HAVE
C SPACE RESERVED FOR THEM IN THE ARRAY WORK.
      DD=VEC1(1)*VEC2(1)
      IF(LGTH-1)300,300,100
  100 DO 200 J=2,LGTH
        DD=DD+VEC1(J)*VEC2(J)
  200   CONTINUE
  300 DOTPRD=DD
      RETURN
      END
      SUBROUTINE REFWL(NDM,NCOR,ICOR,PMAT,PMAT1,NPARM,NUMGR,IXRCT,
     *SAVE,WPT)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION ICOR(NPARM+1),PMAT(NPARM+1,NUMGR),PMAT1(NPARM+1,NUMGR),
     *WPT(NPARM+1),IXRCT(2*NPARM),SAVE(NPARM)
C
C THIS SUBROUTINE ATTEMPTS TO REFINE THE NDM DIMENSIONAL VECTOR WPT
C PRODUCED BY WOLFE BY DIRECTLY SOLVING THE SYSTEM
C SUMMATION(PMAT(I,J)*WPT(I), I=1,...,NDM) = -PMAT(NDM+1,J) FOR J =
C ICOR(L), L=1,...,NCOR.
C NRESL RESOLVENTS ARE CHOSEN BY TOTAL PIVOTING.  IF NRESL .LT. NDM THEN
C THE REMAINING NDM-NRESL ELEMENTS OF WPT ARE KEPT FORM THE OLD WPT.
C ITRLM STEPS OF ITERATIVE REFINEMENT ARE ATTEMPTED AT THE END.
C
C COMPUTE MACHINE AND PRECISION DEPENDENT CONSTANTS.
C     NWRIT=I1MACH(2)
      SPCMN=D1MACH(3)
      TOLE=SPCMN
      ITRLM=2
      ITRCT=0
      NRESL=0
      N=NDM+1
C IF NCOR=0 WE HAVE NOTHING TO DO SO WE RETURN.
      IF(NCOR)100,100,200
C
  100 RETURN
C
C COPY COLUMN ICOR(L) OF PMAT WITH THE SIGN OF THE LAST ELEMENT REVERSED
C INTO COLUMN L OF THE WORK MATRIX PMAT1 FOR L=1,...,NCOR.
  200 DO 400 L=1,NCOR
        J=ICOR(L)
        DO 300 I=1,NDM
          PMAT1(I,L)=PMAT(I,J)
  300     CONTINUE
        PMAT1(N,L)=-PMAT(N,J)
  400   CONTINUE
C
C
C NOW COLUMN REDUCE PMAT1.  NOTE THAT PMAT1 IS THE TRANSPOSE OF THE USUAL
C AUGMENTED MATRIX FOR SOLVING A LINEAR SYSTEM OF EQUATONS.
C THERE WILL BE AT MOST MAXRS = MIN(NDM,NCOR) RESOLVENTS.
      MAXRS=NCOR
      IF(NDM-MAXRS)430,470,470
  430 MAXRS=NDM
  470 DO 1900 K=1,MAXRS
C
C SEARCH FOR THE INDICES IMAX AND JMAX WITH 1 .LE. IMAX .LE. NDM, 1 .LE.
C JMAX .LE. NCOR, PMAT1(IMAX,JMAX) IS NOT IN THE ROW OR COLUMN OF ANY
C OTHER RESOLVENT (I.E. PIVOT), AND ABS(PMAT1(IMAX,JMAX)) IS MAXIMIZED.
C WE USE THE VECTOR IXRCT TO SAVE THE RESOLVENT POSITIONS TO SAVE SPACE.
        JSTRT=0
        DO 1300 J=1,NCOR
          IF(NRESL)700,700,500
  500     DO 600 L=1,NRESL
            IF(J-IXRCT(2*L))600,1300,600
  600       CONTINUE
C HERE THERE IS NO EARLIER RESOLVENT IN COLUMN J.
  700     DO 1200 I=1,NDM
            IF(NRESL)1000,1000,800
  800       DO 900 L=1,NRESL
              IF(I-IXRCT(2*L-1))900,1200,900
  900         CONTINUE
C HERE THERE IS NO EARLIER RESOLVENT IN ROW I.
 1000       AA=ABS(PMAT1(I,J))
            IF(JSTRT)1030,1030,1070
 1030       JSTRT=1
            GO TO 1100
 1070       IF(AA-AMAX)1200,1200,1100
 1100       AMAX=AA
            IMAX=I
            JMAX=J
 1200       CONTINUE
 1300     CONTINUE
C IF THE ABSOLUTE VALUE OF THIS RESOLVENT IS VERY SMALL WE DO NOT ATTEMPT
C ANY FURTHER COLUMN OPERATIONS.
        IF(AMAX-TOLE)2000,1400,1400
C INCREMENT NRESL AND PUT THE LOCATION OF THE NRESLTH RESOLVENT IN
C (IXRCT(2*L-1),IXRCT(2*L)).
 1400   NRESL=NRESL+1
        IXRCT(2*NRESL-1)=IMAX
        IXRCT(2*NRESL)=JMAX
C
C NOW ELIMINATE WPT(IMAX) FROM THOSE COLUMNS WHICH DO NOT CONTAIN ANY OF
C THE RESOLVENTS FOUND SO FAR (INCLUDING THE PRESENT RESOLVENT).
        DO 1800 J=1,NCOR
          DO 1500 L=1,NRESL
            IF(J-IXRCT(2*L))1500,1800,1500
 1500       CONTINUE
C HERE COLUMN J DOES NOT CONTAIN ANY OF THE RESOLVENTS FOUND SO FAR, AND
C WE COMPUTE THE FACTOR FOR THE COLUMN OPERATION NEEDED TO ZERO OUT
C PMAT1(IMAX,J) (ALTHOUGH WE DO NOT ACTUALLY WRITE IN THE ZERO).
          FACT=PMAT1(IMAX,J)/PMAT1(IMAX,JMAX)
C NOW DO THE OPERATION IN COLUMN J FOR ALL ROWS NOT CONTAINING A
C RESOLVENT.  THE ELEMENTS IN THIS COLUMN IN THE ROWS WHICH CONTAIN AN
C EARLIER (OR PRESENT) RESOLVENT WILL NOT BE NEEDED LATER.
          DO 1700 I=1,N
            DO 1600 L=1,NRESL
              IF(I-IXRCT(2*L-1))1600,1700,1600
 1600         CONTINUE
            PMAT1(I,J)=PMAT1(I,J)-FACT*PMAT1(I,JMAX)
 1700       CONTINUE
 1800     CONTINUE
 1900   CONTINUE
C END OF COLUMN REDUCTION OF PMAT1.
C
C
C IF NRESL=0 THEN ALL THE ELEMENTS IN PMAT1 FOR 1 .LE. I .LE. NDM AND
C 1 .LE. J .LE. NCOR WERE VERY SMALL IN ABSOLUTE VALUE, AND THERE IS
C NOTHING WE CAN DO, SO WE RETURN.
 2000 IF(NRESL)100,100,2100
C
C
C NOW DO BACK SUBSTITUTION TO COMPUTE, FOR K=NRESL,...,1,
C WPT(IXRCT(2*K-1)) = (PMAT1(NDM+1,IXRCT(2*K)) - SUMMATION(
C PMAT1(I,IXRCT(2*K))*WPT(I), FOR I = 1,...,NDM, I .NE. IXRCT(2*L-1)
C FOR ANY L=1,...,K))/PMAT1(IXRCT(2*K-1),IXRCT(2*K)).  IF WE ARE IN AN
C ITERATIVE REFINEMENT STEP WE WISH TO CONSIDER WPT(I) (WHICH IS THEN
C JUST A CORRECTION TO WPT(I)) = 0.0 IF I CORRESPONDS TO NO RESOLVENT
C (SINCE THE VALUE OF SUCH WPT(I) IN SAVE SHOULD NOT CHANGE) SO WE OMIT
C THE CORRESPONDING TERMS IN THE SUMMATION ABOVE.
 2100 DO 2400 KK=1,NRESL
        K=NRESL-KK+1
        IMAX=IXRCT(2*K-1)
        JMAX=IXRCT(2*K)
        WPT(IMAX)=PMAT1(N,JMAX)
        DO 2300 I=1,NDM
          DO 2200 L=1,K
            IF(I-IXRCT(2*L-1))2200,2300,2200
 2200       CONTINUE
C HERE ROW I CONTAINS NO EARLIER (OR PRESENT) RESOLVENTS.
          IF(ITRCT)2280,2280,2220
 2220     IF(K-NRESL)2240,2300,2300
C HERE WE ARE DOING ITERATIVE REFINEMENT, K .LT. NRESL, AND I .NE.
C IXRCT(2*L-1) FOR L=1,...,K.  WE WILL USE THE TERM CORRESPONDING TO
C WPT(I) IFF I = IXRCT(2*L-1) FOR SOME L = K+1,...,NRESL.
 2240     KP1=K+1
          DO 2260 L=KP1,NRESL
            IF(I-IXRCT(2*L-1))2260,2280,2260
 2260       CONTINUE
          GO TO 2300
 2280     WPT(IMAX)=WPT(IMAX)-PMAT1(I,JMAX)*WPT(I)
 2300     CONTINUE
        WPT(IMAX)=WPT(IMAX)/PMAT1(IMAX,JMAX)
 2400   CONTINUE
C END OF BACK SUBSTITUTION.
C
C
C IF ITRCT IS POSITIVE THEN WPT WILL CONTAIN ONLY AN ITERATIVE
C REFINEMENT CORRECTION IN THOSE POSITIONS CORRESPONDING TO RESOLVENTS
C AND WE ADD THIS TO SAVE TO GET THE TRUE WPT.
      IF(ITRCT)2900,2900,2500
 2500 DO 2800 I=1,NDM
        DO 2600 L=1,NRESL
          IF(I-IXRCT(2*L-1))2600,2700,2600
 2600     CONTINUE
        GO TO 2800
 2700   WPT(I)=WPT(I)+SAVE(I)
 2800   CONTINUE
C
C
C NOW COMPUTE THE RESIDUAL AND PUT IT INTO PMAT1(NDM+1,.).
 2900 DO 3200 K=1,NCOR
C COMPUTE THE COLUMN INDEX KCOL IN PMAT CORRESPONDING TO COLUMN K IN
C PMAT1.
        KCOL=ICOR(K)
        PMAT1(N,K)=-PMAT(N,KCOL)
        DO 3100 I=1,NDM
          PMAT1(N,K)=PMAT1(N,K)-PMAT(I,KCOL)*WPT(I)
 3100     CONTINUE
 3200   CONTINUE
C
C COMPUTE THE WORST ABSOLUTE VALUE OF THE RESIDUAL ELEMENTS.
      DO 3500 K=1,NCOR
        AA=ABS(PMAT1(N,K))
        IF(K-1)3400,3400,3300
 3300   IF(AA-WRST)3500,3500,3400
 3400   WRST=AA
 3500   CONTINUE
C
      IF(ITRCT)3700,3700,3800
 3700 WRSTO=WRST
      GO TO 4100
 3800 IF(WRST-WRSTO)4100,4100,3900
C HERE ITRCT .GT. 0 AND WRST .GT. WRSTO, SO WE GO BACK TO THE PREVIOUS
C WPT AND RETURN.
 3900 WRST=WRSTO
      DO 4000 I=1,NDM
        WPT(I)=SAVE(I)
 4000   CONTINUE
      RETURN
C
 4100 IF(ITRCT-ITRLM)4200,100,100
C HERE ITRCT .LT. ITRLM AND WE INCREMENT ITRCT AND SET UP FOR THE ITRCTTH
C ITERATIVE REFINEMENT STEP.
 4200 ITRCT=ITRCT+1
C COPY WPT INTO SAVE.
      DO 4300 I=1,NDM
        SAVE(I)=WPT(I)
 4300   CONTINUE
      GO TO 2100
      END
C*****END OF CONMAX PACKAGE.