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.