* ****************************************************************************** SUBROUTINE A0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,RHG,EMAG, 1 ESAVE) C REAL TM(NVAR),NG(M),T(NVAR,KMAX),RHG(1) C REAL RHG(MIN(M-1,KMAX)) REAL ERROR(NVAR,1),EBEST(NVAR),EMAG(1) C REAL ERROR(NVAR,MIN(M-1,KMAX)),EMAG(MIN(M-1,KMAX)) LOGICAL XPOLY,ESAVE C REAL U,V,TI,TV,TEMP REAL ERR C IF (M.GT.1) GO TO 20 C C ... INITIALIZE T. C DO 10 I=1,NVAR 10 T(I,1)=TM(I) C GO TO 80 C 20 MR=MIN0(M-1,KMAX) C DO 30 J=1,MR MMJ=M-J RHG(J)=NG(M)/NG(MMJ) EMAG(J)=1.0E0+1.0E0/(RHG(J)-1.0E0) IF (XPOLY) RHG(J)=RHG(J)-1.0E0 30 CONTINUE C DO 70 I=1,NVAR C V=0.0E0 U=T(I,1) TI=TM(I) T(I,1)=TI C DO 60 J=1,MR C C ......... OBTAIN SIGNED ERROR ESTIMATE. C ERR=(T(I,J)-U)*EMAG(J) IF (ESAVE) ERROR(I,J)=ERR ERR=ABS(ERR) IF (J.EQ.1) EBEST(I)=ERR EBEST(I)=AMIN1(EBEST(I),ERR) IF (EBEST(I).EQ.ERR) JBEST=J C IF (J.EQ.KMAX) GO TO 60 C IF (XPOLY) GO TO 40 C C ......... RATIONAL EXTRAPOLATION. C TV=TI-V TEMP=RHG(J)*(U-V)-TV IF (TEMP.NE.0.0E0) TI=TI+(TI-U)*(TV/TEMP) V=U GO TO 50 C C ......... POLYNOMIAL EXTRAPOLATION. C 40 TI=TI+(TI-U)/RHG(J) C 50 U=T(I,J+1) T(I,J+1)=TI 60 CONTINUE C 70 TM(I)=T(I,JBEST) C 80 RETURN C END SUBROUTINE A7SST(IV, LIV, LV, V) C C *** ASSESS CANDIDATE STEP (***SOL VERSION 2.3) *** C INTEGER LIV, LV INTEGER IV(LIV) REAL V(LV) C C *** PURPOSE *** C C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM- C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING C BELOW. C C-------------------------- PARAMETER USAGE -------------------------- C C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF IV VALUES REFERENCED. C LIV (IN) LENGTH OF IV ARRAY. C LV (IN) LENGTH OF V ARRAY. C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF V VALUES REFERENCED. C C *** IV VALUES REFERENCED *** C C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION, C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE C UNCHANGED SINCE THE PREVIOUS RETURN OF A7SST. C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE C FOLLOWING VALUES... C 1 = SWITCH MODELS OR TRY SMALLER STEP. C 2 = SWITCH MODELS OR ACCEPT STEP. C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT C TESTS. C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED. C 5 = RECOMPUTE STEP (USING THE SAME MODEL). C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT C EVALUATE THE OBJECTIVE FUNCTION. C 7 = X-CONVERGENCE (SEE V(XCTOL)). C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)). C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE. C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)). C 11 = SINGULAR CONVERGENCE (SEE V(LMAXS)). C 12 = FALSE CONVERGENCE (SEE V(XFTOL)). C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT. C RETURN CODE I HAS PRECEDENCE OVER I+1 FOR I = 9, 10, 11. C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL). C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION. C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION, C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT. C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION. C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED. C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER C OF DECREASES) SO FAR THIS ITERATION. C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE C RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED, C TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO C 0 OTHERWISE. C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE C CURRENT ITERATION. C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER. C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL, C IN WHICH CASE A7SST SETS IV(SWITCH) = 1. C IV(TOOBIG) (I/O) IS NONZERO ON INPUT IF STEP WAS TOO BIG (E.G., IF C IT WOULD CAUSE OVERFLOW). IT IS SET TO 0 ON RETURN. C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS. C C *** V VALUES REFERENCED *** C C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS C THAN V(AFCTOL) AND A7SST DOES NOT RETURN WITH C IV(IRC) = 11, THEN A7SST RETURNS WITH IV(IRC) = 10. C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS C NONZERO. C V(DSTNRM) (IN) THE 2-NORM OF D*STEP. C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP. C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED, C I.E., FOR V(NREDUC) .GE. 0). C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC- C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE, C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE. C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE). C V(FLSTGD) (I/O) SAVED VALUE OF V(F). C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION. C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP. C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT. C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS. C V(LMAXS) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND). C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9 C DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT C STEP IS A NEWTON STEP, AND IF C V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN A7SST RETURNS C WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, THEN C A7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP) C WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS) C (BY A RETURN WITH IV(IRC) = 6). C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C NEWTON STEP. IF A7SST IS CALLED WITH IV(IRC) = 6, I.E., C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR C USE IN THE SINGULAR CONVERGENCE TEST, THEN V(NREDUC) IS C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED. C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP. C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C CURRENT STEP. C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS, C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED. C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1. C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0. C V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED C (E.G.) BY FUNCTION RLDST AS C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P). C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE- C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN C A7SST RETURNS WITH IV(IRC) = 8 OR 9. C V(SCTOL) (IN) SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS). C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP. C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED C VALUE = 0.1. C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED C VALUE = 10**-4. C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75. C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN C A7SST RETURNS IV(IRC) = 7 OR 9. C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL), C THEN A7SST RETURNS WITH IV(IRC) = 12. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER, C OR LEVENBERG-MARQUARDT STEPS. C C *** ALGORITHM NOTES *** C C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS, C A7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS. C C *** USAGE NOTES *** C C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O C VALUES EXCEPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER- C ANCES SHOULD BE CHANGED. C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN C CHANGE THE STOPPING TOLERANCES AND CALL A7SST AGAIN, IN WHICH C CASE THE STOPPING TESTS WILL BE REPEATED. C C *** REFERENCES *** C C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3. C C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** HISTORY *** C C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY. C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS C PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR C CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** NO EXTERNAL FUNCTIONS AND SUBROUTINES *** C C-------------------------- LOCAL VARIABLES -------------------------- C LOGICAL GOODX INTEGER I, NFC REAL EMAX, EMAXS, GTS, RFAC1, XMAX REAL HALF, ONE, ONEP2, TWO, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0, 1 GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL, 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN, 3 RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM, 4 STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, 5 XFTOL, XIRC C C *** DATA INITIALIZATIONS *** C C/6 C DATA HALF/0.5E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, TWO/2.E+0/, C 1 ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ONE=1.E+0, ONEP2=1.2E+0, TWO=2.E+0, 1 ZERO=0.E+0) C/ C C/6 C DATA IRC/29/, MLSTGD/32/, MODEL/5/, NFCALL/6/, NFGCAL/7/, C 1 RADINC/8/, RESTOR/9/, STAGE/10/, STGLIM/11/, SWITCH/12/, C 2 TOOBIG/2/, XIRC/13/ C/7 PARAMETER (IRC=29, MLSTGD=32, MODEL=5, NFCALL=6, NFGCAL=7, 1 RADINC=8, RESTOR=9, STAGE=10, STGLIM=11, SWITCH=12, 2 TOOBIG=2, XIRC=13) C/ C/6 C DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, DSTSAV/18/, C 1 F/10/, FDIF/11/, FLSTGD/12/, F0/13/, GTSLST/14/, GTSTEP/4/, C 2 INCFAC/23/, LMAXS/36/, NREDUC/6/, PLSTGD/15/, PREDUC/7/, C 3 RADFAC/16/, RDFCMN/24/, RDFCMX/25/, RELDX/17/, RFCTOL/32/, C 4 SCTOL/37/, STPPAR/5/, TUNER1/26/, TUNER2/27/, TUNER3/28/, C 5 XCTOL/33/, XFTOL/34/ C/7 PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, DSTSAV=18, 1 F=10, FDIF=11, FLSTGD=12, F0=13, GTSLST=14, GTSTEP=4, 2 INCFAC=23, LMAXS=36, NREDUC=6, PLSTGD=15, PREDUC=7, 3 RADFAC=16, RDFCMN=24, RDFCMX=25, RELDX=17, RFCTOL=32, 4 SCTOL=37, STPPAR=5, TUNER1=26, TUNER2=27, TUNER3=28, 5 XCTOL=33, XFTOL=34) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NFC = IV(NFCALL) IV(SWITCH) = 0 IV(RESTOR) = 0 RFAC1 = ONE GOODX = .TRUE. I = IV(IRC) IF (I .GE. 1 .AND. I .LE. 12) 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 110 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 110 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILITY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 110, 110, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IV(TOOBIG) = 0 IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 IV(TOOBIG) = 0 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 IV(RESTOR) = 1 V(F) = V(FLSTGD) GO TO 999 C 70 IF (V(F) .LT. V(FLSTGD)) GO TO 110 C C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. *** C IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80 IV(MODEL) = IV(MLSTGD) IV(SWITCH) = 1 C C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F). C 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 110 IF (IV(STAGE) .LT. IV(STGLIM)) THEN GOODX = .FALSE. ELSE IF (NFC .LT. IV(NFGCAL) + IV(STGLIM) + 2) THEN GOODX = .FALSE. ELSE IF (IV(SWITCH) .NE. 0) THEN GOODX = .FALSE. ENDIF IV(RESTOR) = 3 V(F) = V(FLSTGD) V(PREDUC) = V(PLSTGD) V(GTSTEP) = V(GTSLST) IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV) V(DSTNRM) = V(DSTSAV) IF (GOODX) THEN C C *** ACCEPT PREVIOUS SLIGHTLY REDUCING STEP *** C V(FDIF) = V(F0) - V(F) IV(IRC) = 4 V(RADFAC) = RFAC1 GO TO 999 ENDIF NFC = IV(NFGCAL) C 110 V(FDIF) = V(F0) - V(F) IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 140 IF (IV(RADINC) .GT. 0) GO TO 140 C C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE C *** -- SO TRY NEW MODEL OR SMALLER RADIUS C IF (V(F) .LT. V(F0)) GO TO 120 IV(MLSTGD) = IV(MODEL) V(FLSTGD) = V(F) V(F) = V(F0) IV(RESTOR) = 1 GO TO 130 120 IV(NFGCAL) = NFC 130 IV(IRC) = 1 IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 160 IV(IRC) = 5 IV(RADINC) = IV(RADINC) - 1 GO TO 160 C C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED *** C 140 IV(NFGCAL) = NFC RFAC1 = ONE V(DSTSAV) = V(DSTNRM) IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 190 C C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS C *** OR ACCEPT STEP WITH DECREASED RADIUS. C IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 150 C *** CONSIDER SWITCHING MODELS *** IV(IRC) = 2 GO TO 160 C C *** ACCEPT STEP WITH DECREASED RADIUS *** C 150 IV(IRC) = 4 C C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR *** C 160 IV(XIRC) = IV(IRC) EMAX = V(GTSTEP) + V(FDIF) V(RADFAC) = HALF * RFAC1 IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * AMAX1(V(RDFCMN), 1 HALF * V(GTSTEP)/EMAX) C C *** DO FALSE CONVERGENCE TEST *** C 170 IF (V(RELDX) .LE. V(XFTOL)) GO TO 180 IV(IRC) = IV(XIRC) IF (V(F) .LT. V(F0)) GO TO 200 GO TO 230 C 180 IV(IRC) = 12 GO TO 240 C C *** HANDLE GOOD FUNCTION DECREASE *** C 190 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 210 C C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS. C IF (IV(RADINC) .LT. 0) GO TO 210 IF (IV(RESTOR) .EQ. 1) GO TO 210 IF (IV(RESTOR) .EQ. 3) GO TO 210 C C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON C *** STEP. C V(RADFAC) = V(RDFCMX) GTS = V(GTSTEP) IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS) 1 V(RADFAC) = AMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF))) IV(IRC) = 4 IF (V(STPPAR) .EQ. ZERO) GO TO 230 IF (V(DST0) .GE. ZERO .AND. (V(DST0) .LT. TWO*V(DSTNRM) 1 .OR. V(NREDUC) .LT. ONEP2*V(FDIF))) GO TO 230 C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH C *** A LARGER RADIUS. IV(IRC) = 5 IV(RADINC) = IV(RADINC) + 1 C C *** SAVE VALUES CORRESPONDING TO GOOD STEP *** C 200 V(FLSTGD) = V(F) IV(MLSTGD) = IV(MODEL) IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 230 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 210 V(RADFAC) = ONE IV(IRC) = 3 GO TO 230 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 220 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 240 IV(IRC) = 12 GO TO 240 C C *** PERFORM CONVERGENCE TESTS *** C 230 IV(XIRC) = IV(IRC) 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3 IF ( ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = V(RFCTOL) * ABS(V(F0)) EMAXS = V(SCTOL) * ABS(V(F0)) IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR. 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 250 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL) 1 .AND. GOODX) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR C *** CONVERGENCE TEST. C 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(STPPAR) .EQ. ZERO) GO TO 999 IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260 IF (V(PREDUC) .GE. EMAXS) GO TO 999 IF (V(DST0) .LE. ZERO) GO TO 270 IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999 GO TO 270 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999 XMAX = V(LMAXS) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999 270 IF (V(NREDUC) .LT. ZERO) GO TO 290 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) I = IV(RESTOR) IV(RESTOR) = 2 IF (I .EQ. 3) IV(RESTOR) = 0 IV(IRC) = 6 GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 280 V(GTSTEP) = V(GTSLST) V(DSTNRM) = ABS(V(DSTSAV)) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) IV(RESTOR) = 3 290 IF (-V(NREDUC) .LE. V(SCTOL) * ABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST LINE OF A7SST FOLLOWS *** END SUBROUTINE A9RNTC(A, NITEMS, IOUT, MCOL, W, D) C C THIS IS THE DOCUMENTED ROUTINE APRNTC, BUT WITHOUT THE CALLS TO C SETERR- BECAUSE IT IS CALLED BY SETERR. C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE COMPLEX ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS 2(1PEW.D). C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE COMPLEX ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D) C C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D) C C C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY C SETERR, SO IT CANNOT CALL SETERR. C INTEGER NITEMS, IOUT, MCOL, W, D C/R C REAL A(2,NITEMS) C/C COMPLEX A(NITEMS) C/ C INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX, 1 EXPENT, I1MACH, ICEIL, IABS, I10WID C/6S C INTEGER IFMT1(20), IFMT2(18), BLANK, STAR C INTEGER IFMT1C(20), IFMT2C(18) C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*18 IFMT2C EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP C/R C REAL LINE(2,18), LAST(2,18) C/C COMPLEX LINE(18), LAST(18) C/ REAL LOGETA C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/ C/ C C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/ C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/ C DATA IFMT1(11) /1H1/, IFMT2(11) /1H / C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/ C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H / C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./ C DATA IFMT1(16) /1H,/, IFMT2(16) /1H / C DATA IFMT1(17) /1H2/, IFMT2(17) /1H / C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/ DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/ DATA IFMT1(11) /'1'/, IFMT2(11) /' '/ DATA IFMT1(12) /','/, IFMT2(12) /'E'/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /' '/ DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/ DATA IFMT1(16) /','/, IFMT2(16) /' '/ DATA IFMT1(17) /'2'/, IFMT2(17) /' '/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED. C IF (EXPENT .GT. 0) GO TO 10 LOGETA = ALOG10(FLOAT(I1MACH(10))) EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1))) EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13))) EXPENT = I10WID(MAX0(EMIN, EMAX)) C C COMPUTE THE FORMATS. C 10 WW = MIN0(99, MAX0(W, 5+EXPENT)) CALL S88FMT(2, WW, IFMT2(13)) DD = MIN0(D, (WW-(5+EXPENT))) CALL S88FMT(2, DD, IFMT2(16)) C C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE. C NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/(2*WW))) CALL S88FMT(1, (2*NCOL), IFMT2(11)) WW = WW-2 C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 C/R C LINE(1,J) = A(1,I) C LINE(2,J) = A(2,I) C/C LINE(J) = A(I) C/ IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL C/R C IF (LAST(1,K) .NE. LINE(1,K) .OR. C 1 LAST(2,K) .NE. LINE(2,K)) C 2 DUP = .FALSE. C/C IF (REAL(LAST(K)) .NE. REAL(LINE(K)) .OR. 1 AIMAG(LAST(K)) .NE. AIMAG(LINE(K))) 2 DUP = .FALSE. C/ 30 CONTINUE IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 C/R C 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(1,K), C 1 LAST(2,K), K=1,NCOL) C 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(1,K), C 1 LINE(2,K), K=1,J) C/C 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) C/ COUNT = 1 DO 60 K=1,NCOL C/R C LAST(1,K) = LINE(1,K) C 60 LAST(2,K) = LINE(2,K) C/C 60 LAST(K) = LINE(K) C/ 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE A9RNTD(A, NITEMS, IOUT, MCOL, W, D) C C THIS IS THE DOCUMENTED ROUTINE APRNTD, BUT WITHOUT THE CALLS TO C SETERR - BECAUSE IT IS CALLED BY SETERR. C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE DOUBLE PRECISION ARRAY, C A, ON OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS 1PDW.D. C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE DOUBLE PRECISION ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (1PDW.D) C C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PDW.D) C C C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY C SETERR, SO IT CANNOT CALL SETERR. C INTEGER NITEMS, IOUT, MCOL, W, D DOUBLE PRECISION A(NITEMS) C INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX, 1 EXPENT, I1MACH, ICEIL, IABS, I10WID C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*18 IFMT2C EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP DOUBLE PRECISION LINE(18), LAST(18) REAL LOGETA C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/ C/ C C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/ C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/ C DATA IFMT1(11) /1H1/, IFMT2(11) /1H / C DATA IFMT1(12) /1H,/, IFMT2(12) /1HD/ C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H / C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./ C DATA IFMT1(16) /1H,/, IFMT2(16) /1H / C DATA IFMT1(17) /1H2/, IFMT2(17) /1H / C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/ DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/ DATA IFMT1(11) /'1'/, IFMT2(11) /' '/ DATA IFMT1(12) /','/, IFMT2(12) /'D'/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /' '/ DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/ DATA IFMT1(16) /','/, IFMT2(16) /' '/ DATA IFMT1(17) /'2'/, IFMT2(17) /' '/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED. C IF (EXPENT .GT. 0) GO TO 10 LOGETA = ALOG10(FLOAT(I1MACH(10))) EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(15)-1))) EMAX = ICEIL(LOGETA*FLOAT(I1MACH(16))) EXPENT = I10WID(MAX0(EMIN, EMAX)) C C COMPUTE THE FORMATS. C 10 WW = MIN0(99, MAX0(W, 5+EXPENT)) CALL S88FMT(2, WW, IFMT2(13)) DD = MIN0(D, (WW-(5+EXPENT))) CALL S88FMT(2, DD, IFMT2(16)) C C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE. C NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW)) CALL S88FMT(1, NCOL, IFMT2(11)) WW = WW-2 C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = A(I) IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE A9RNTI(A, NITEMS, IOUT, MCOL, W) C C THIS IS THE DOCUMENTED ROUTINE APRNTI, BUT WITHOUT THE CALLS TO C SETERR - BECAUSE IT IS CALLED BY SETERR. C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE INTEGER ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS IW. C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE INTEGER ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (IW) C C C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY C SETERR, SO IT CANNOT CALL SETERR. C C INTEGER NITEMS, IOUT, MCOL, W INTEGER A(NITEMS) C INTEGER MAX0, MIN0, WW C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(14), IFMT2C(14), BLANK, STAR C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(14), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*14 IFMT2C EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP INTEGER LINE(40), LAST(40) C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/ C/ C C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H / C DATA IFMT1(10) /1HA/, IFMT2(10) /1H / C DATA IFMT1(11) /1H1/, IFMT2(11) /1HI/ C DATA IFMT1(12) /1H,/, IFMT2(12) /1H / C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H)/ C DATA IFMT1(15) /1HX/ C DATA IFMT1(16) /1H,/ C DATA IFMT1(17) /1H2/ C DATA IFMT1(18) /1HA/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/ DATA IFMT1(10) /'A'/, IFMT2(10) /' '/ DATA IFMT1(11) /'1'/, IFMT2(11) /'I'/ DATA IFMT1(12) /','/, IFMT2(12) /' '/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /')'/ DATA IFMT1(15) /'X'/ DATA IFMT1(16) /','/ DATA IFMT1(17) /'2'/ DATA IFMT1(18) /'A'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C COMPUTE THE FORMATS. C WW = MIN0(99, MAX0(W, 2)) CALL S88FMT(2, WW, IFMT2(12)) NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160) - INDW)/WW)) CALL S88FMT(2, NCOL, IFMT2(9)) WW = WW-2 CALL S88FMT(2, WW, IFMT1(13)) C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C 10 I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = A(I) IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE A9RNTL(A, NITEMS, IOUT, MCOL) C C THIS IS THE DOCUMENTED ROUTINE APRNTL, BUT WITHOUT THE CALLS TO C SETERR - BECAUSE IT IS CALLED BY SETERR. C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE LOGICAL ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE T OR F VALUES ARE PRINTED RIGHT-ADJUSTED IN A FIELD OF WIDTH 4. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE LOGICAL ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY C SETERR, SO IT CANNOT CALL SETERR. C C INTEGER NITEMS, IOUT, MCOL LOGICAL A(NITEMS) C INTEGER MAX0, MIN0 C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(19), IFMT2C(19), BLANK, C 1 STAR, TCHAR, FCHAR C INTEGER LINE(40), LAST(40) C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(19), BLANK, STAR, TCHAR, FCHAR CHARACTER*20 IFMT1C CHARACTER*19 IFMT2C EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C) CHARACTER*1 LINE(40), LAST(40) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP C C/6S C DATA BLANK/1H /, STAR/1H*/, TCHAR/1HT/, FCHAR/1HF/, INDW/7/ C/7S DATA BLANK/' '/, STAR/'*'/, TCHAR/'T'/, FCHAR/'F'/, INDW/7/ C/ C C C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H / C DATA IFMT1(10) /1HA/, IFMT2(10) /1H / C DATA IFMT1(11) /1H1/, IFMT2(11) /1H(/ C DATA IFMT1(12) /1H,/, IFMT2(12) /1H3/ C DATA IFMT1(13) /1H /, IFMT2(13) /1HX/ C DATA IFMT1(14) /1H2/, IFMT2(14) /1H,/ C DATA IFMT1(15) /1HX/, IFMT2(15) /1H1/ C DATA IFMT1(16) /1H,/, IFMT2(16) /1HA/ C DATA IFMT1(17) /1H2/, IFMT2(17) /1H1/ C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/, IFMT2(19) /1H)/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/ DATA IFMT1(10) /'A'/, IFMT2(10) /' '/ DATA IFMT1(11) /'1'/, IFMT2(11) /'('/ DATA IFMT1(12) /','/, IFMT2(12) /'3'/ DATA IFMT1(13) /' '/, IFMT2(13) /'X'/ DATA IFMT1(14) /'2'/, IFMT2(14) /','/ DATA IFMT1(15) /'X'/, IFMT2(15) /'1'/ DATA IFMT1(16) /','/, IFMT2(16) /'A'/ DATA IFMT1(17) /'2'/, IFMT2(17) /'1'/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/, IFMT2(19) /')'/ DATA IFMT1(20) /')'/ C/ C C C COMPUTE THE NUMBER OF FIELDS OF 4 ACROSS A LINE. C NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160)-INDW)/4)) C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE 4-CHARACTER SPACE. CALL S88FMT(2, NCOL, IFMT2(9)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C 10 I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = FCHAR IF ( A(I) ) LINE(J) = TCHAR IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE A9RNTR(A, NITEMS, IOUT, MCOL, W, D) C C THIS IS THE DOCUMENTED ROUTINE APRNTR, BUT WITHOUT THE CALLS TO C SETERR - BECAUSE IT IS CALLED BY SETERR. C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE REAL ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS 1PEW.D. C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE REAL ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D) C C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D) C C C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY C SETERR, SO IT CANNOT CALL SETERR. C C INTEGER NITEMS, IOUT, MCOL, W, D REAL A(NITEMS) C INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX, 1 EXPENT, I1MACH, ICEIL, IABS, I10WID C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*18 IFMT2C EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP REAL LINE(18), LAST(18), LOGETA C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/ C/ C C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/ C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/ C DATA IFMT1(11) /1H1/, IFMT2(11) /1H / C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/ C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H / C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./ C DATA IFMT1(16) /1H,/, IFMT2(16) /1H / C DATA IFMT1(17) /1H2/, IFMT2(17) /1H / C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/ DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/ DATA IFMT1(11) /'1'/, IFMT2(11) /' '/ DATA IFMT1(12) /','/, IFMT2(12) /'E'/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /' '/ DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/ DATA IFMT1(16) /','/, IFMT2(16) /' '/ DATA IFMT1(17) /'2'/, IFMT2(17) /' '/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED. C IF (EXPENT .GT. 0) GO TO 10 LOGETA = ALOG10(FLOAT(I1MACH(10))) EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1))) EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13))) EXPENT = I10WID(MAX0(EMIN, EMAX)) C C COMPUTE THE FORMATS. C 10 WW = MIN0(99, MAX0(W, 5+EXPENT)) CALL S88FMT(2, WW, IFMT2(13)) DD = MIN0(D, (WW-(5+EXPENT))) CALL S88FMT(2, DD, IFMT2(16)) C C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE. C NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW)) CALL S88FMT(1, NCOL, IFMT2(11)) WW = WW-2 C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = A(I) IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE APRNTC(A, NITEMS, IOUT, MCOL, W, D) C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE COMPLEX ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS 2(1PEW.D). C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE COMPLEX ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D) C C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D) C C C ERROR STATES - C C 1 - NITEMS .LE. ZERO C C 2 - W .GT. MCOL C C 3 - D .LT. ZERO C C 4 - W .LT. D+6 C INTEGER NITEMS, IOUT, MCOL, W, D C/R C REAL A(2,NITEMS) C/C COMPLEX A(NITEMS) C/ C INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX, 1 EXPENT, I1MACH, ICEIL, IABS, I10WID C/6S C INTEGER IFMT1(20), IFMT2(18), BLANK, STAR C INTEGER IFMT1C(20), IFMT2C(18) C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*18 IFMT2C EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP C/R C REAL LINE(2,18), LAST(2,18) C/C COMPLEX LINE(18), LAST(18) C/ REAL LOGETA C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/ C/ C C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/ C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/ C DATA IFMT1(11) /1H1/, IFMT2(11) /1H / C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/ C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H / C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./ C DATA IFMT1(16) /1H,/, IFMT2(16) /1H / C DATA IFMT1(17) /1H2/, IFMT2(17) /1H / C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/ DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/ DATA IFMT1(11) /'1'/, IFMT2(11) /' '/ DATA IFMT1(12) /','/, IFMT2(12) /'E'/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /' '/ DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/ DATA IFMT1(16) /','/, IFMT2(16) /' '/ DATA IFMT1(17) /'2'/, IFMT2(17) /' '/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C/6S C IF (NITEMS .LE. 0) CALL C 1 SETERR(27H APRNTC - NITEMS .LE. ZERO, 27, 1, 2) C/7S IF (NITEMS .LE. 0) CALL 1 SETERR(' APRNTC - NITEMS .LE. ZERO', 27, 1, 2) C/ C C/6S C IF (W .GT. MCOL) CALL C 1 SETERR(22H APRNTC - W .GT. MCOL, 22, 2, 2) C/7S IF (W .GT. MCOL) CALL 1 SETERR(' APRNTC - W .GT. MCOL', 22, 2, 2) C/ C C/6S C IF (D .LT. 0) CALL C 1 SETERR(22H APRNTC - D .LT. ZERO, 22, 3, 2) C/7S IF (D .LT. 0) CALL 1 SETERR(' APRNTC - D .LT. ZERO', 22, 3, 2) C/ C C/6S C IF (W .LT. D+6) CALL C 1 SETERR(21H APRNTC - W .LT. D+6, 21, 4, 2) C/7S IF (W .LT. D+6) CALL 1 SETERR(' APRNTC - W .LT. D+6', 21, 4, 2) C/ C C C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED. C IF (EXPENT .GT. 0) GO TO 10 LOGETA = ALOG10(FLOAT(I1MACH(10))) EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1))) EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13))) EXPENT = I10WID(MAX0(EMIN, EMAX)) C C COMPUTE THE FORMATS. C 10 WW = MIN0(99, MAX0(W, 5+EXPENT)) CALL S88FMT(2, WW, IFMT2(13)) DD = MIN0(D, (WW-(5+EXPENT))) CALL S88FMT(2, DD, IFMT2(16)) C C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE. C NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/(2*WW))) CALL S88FMT(1, (2*NCOL), IFMT2(11)) WW = WW-2 C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 C/R C LINE(1,J) = A(1,J) C LINE(2,J) = A(2,J) C/C LINE(J) = A(I) C/ IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL C/R C IF (LAST(1,K) .NE. LINE(1,K) .OR. C 1 LAST(2,K) .NE. LINE(2,K)) C 2 DUP = .FALSE. C/C IF (REAL(LAST(K)) .NE. REAL(LINE(K)) .OR. 1 AIMAG(LAST(K)) .NE. AIMAG(LINE(K))) 2 DUP = .FALSE. C/ 30 CONTINUE IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 C/R C 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(1,K), C 1 LAST(2,K), K=1,NCOL) C 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(1,K), C 1 LINE(2,K), K=1,J) C/C 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) C/ COUNT = 1 DO 60 K=1,NCOL C/R C LAST(1,K) = LINE(1,K) C 60 LAST(2,K) = LINE(2,K) C/C 60 LAST(K) = LINE(K) C/ 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE APRNTD(A, NITEMS, IOUT, MCOL, W, D) C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE DOUBLE PRECISION ARRAY, C A, ON OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS 1PDW.D. C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE DOUBLE PRECISION ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (1PDW.D) C C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PDW.D) C C C ERROR STATES - C C 1 - NITEMS .LE. ZERO C C 2 - W .GT. MCOL C C 3 - D .LT. ZERO C C 4 - W .LT. D+6 C INTEGER NITEMS, IOUT, MCOL, W, D DOUBLE PRECISION A(NITEMS) C INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX, 1 EXPENT, I1MACH, ICEIL, IABS, I10WID C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*18 IFMT2C EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP DOUBLE PRECISION LINE(18), LAST(18) REAL LOGETA C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/ C/ C C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/ C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/ C DATA IFMT1(11) /1H1/, IFMT2(11) /1H / C DATA IFMT1(12) /1H,/, IFMT2(12) /1HD/ C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H / C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./ C DATA IFMT1(16) /1H,/, IFMT2(16) /1H / C DATA IFMT1(17) /1H2/, IFMT2(17) /1H / C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/ DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/ DATA IFMT1(11) /'1'/, IFMT2(11) /' '/ DATA IFMT1(12) /','/, IFMT2(12) /'D'/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /' '/ DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/ DATA IFMT1(16) /','/, IFMT2(16) /' '/ DATA IFMT1(17) /'2'/, IFMT2(17) /' '/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C/6S C IF (NITEMS .LE. 0) CALL C 1 SETERR(27H APRNTD - NITEMS .LE. ZERO, 27, 1, 2) C/7S IF (NITEMS .LE. 0) CALL 1 SETERR(' APRNTD - NITEMS .LE. ZERO', 27, 1, 2) C/ C C/6S C IF (W .GT. MCOL) CALL C 1 SETERR(22H APRNTD - W .GT. MCOL, 22, 2, 2) C/7S IF (W .GT. MCOL) CALL 1 SETERR(' APRNTD - W .GT. MCOL', 22, 2, 2) C/ C C/6S C IF (D .LT. 0) CALL C 1 SETERR(22H APRNTD - D .LT. ZERO, 22, 3, 2) C/7S IF (D .LT. 0) CALL 1 SETERR(' APRNTD - D .LT. ZERO', 22, 3, 2) C/ C C/6S C IF (W .LT. D+6) CALL C 1 SETERR(21H APRNTD - W .LT. D+6, 21, 4, 2) C/7S IF (W .LT. D+6) CALL 1 SETERR(' APRNTD - W .LT. D+6', 21, 4, 2) C/ C C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED. C IF (EXPENT .GT. 0) GO TO 10 LOGETA = ALOG10(FLOAT(I1MACH(10))) EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(15)-1))) EMAX = ICEIL(LOGETA*FLOAT(I1MACH(16))) EXPENT = I10WID(MAX0(EMIN, EMAX)) C C COMPUTE THE FORMATS. C 10 WW = MIN0(99, MAX0(W, 5+EXPENT)) CALL S88FMT(2, WW, IFMT2(13)) DD = MIN0(D, (WW-(5+EXPENT))) CALL S88FMT(2, DD, IFMT2(16)) C C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE. C NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW)) CALL S88FMT(1, NCOL, IFMT2(11)) WW = WW-2 C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = A(I) IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE APRNTI(A, NITEMS, IOUT, MCOL, W) C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE INTEGER ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS IW. C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE INTEGER ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (IW) C C C ERROR STATES - C C 1 - NITEMS .LE. ZERO C C 2 - W .GT. MCOL C INTEGER NITEMS, IOUT, MCOL, W INTEGER A(NITEMS) C INTEGER MAX0, MIN0, WW C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(14), IFMT2C(14), BLANK, STAR C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(14), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*14 IFMT2C EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP INTEGER LINE(40), LAST(40) C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/ C/ C C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H / C DATA IFMT1(10) /1HA/, IFMT2(10) /1H / C DATA IFMT1(11) /1H1/, IFMT2(11) /1HI/ C DATA IFMT1(12) /1H,/, IFMT2(12) /1H / C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H)/ C DATA IFMT1(15) /1HX/ C DATA IFMT1(16) /1H,/ C DATA IFMT1(17) /1H2/ C DATA IFMT1(18) /1HA/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/ DATA IFMT1(10) /'A'/, IFMT2(10) /' '/ DATA IFMT1(11) /'1'/, IFMT2(11) /'I'/ DATA IFMT1(12) /','/, IFMT2(12) /' '/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /')'/ DATA IFMT1(15) /'X'/ DATA IFMT1(16) /','/ DATA IFMT1(17) /'2'/ DATA IFMT1(18) /'A'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C/6S C IF (NITEMS .LE. 0) CALL C 1 SETERR(27H APRNTI - NITEMS .LE. ZERO, 27, 1, 2) C/7S IF (NITEMS .LE. 0) CALL 1 SETERR(' APRNTI - NITEMS .LE. ZERO', 27, 1, 2) C/ C C/6S C IF (W .GT. MCOL) CALL C 1 SETERR(22H APRNTI - W .GT. MCOL, 22, 2, 2) C/7S IF (W .GT. MCOL) CALL 1 SETERR(' APRNTI - W .GT. MCOL', 22, 2, 2) C/ C C COMPUTE THE FORMATS. C WW = MIN0(99, MAX0(W, 2)) CALL S88FMT(2, WW, IFMT2(12)) NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160) - INDW)/WW)) CALL S88FMT(2, NCOL, IFMT2(9)) WW = WW-2 CALL S88FMT(2, WW, IFMT1(13)) C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C 10 I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = A(I) IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE APRNTL(A, NITEMS, IOUT, MCOL) C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE LOGICAL ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE T OR F VALUES ARE PRINTED RIGHT-ADJUSTED IN A FIELD OF WIDTH 4. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE LOGICAL ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C C ERROR STATES - C C 1 - NITEMS .LE. ZERO C INTEGER NITEMS, IOUT, MCOL LOGICAL A(NITEMS) C INTEGER MAX0, MIN0 C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(19), IFMT2C(19) C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1)) C INTEGER BLANK, FCHAR, STAR, TCHAR C/7S CHARACTER*1 IFMT1(20), IFMT2(19), BLANK, FCHAR, STAR, TCHAR CHARACTER*20 IFMT1C CHARACTER*19 IFMT2C EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP C/6S C INTEGER LINE(40), LAST(40) C DATA BLANK/1H /, STAR/1H*/, TCHAR/1HT/, FCHAR/1HF/, INDW/7/ C/7S CHARACTER*1 LINE(40), LAST(40) DATA BLANK/' '/, STAR/'*'/, TCHAR/'T'/, FCHAR/'F'/, INDW/7/ C/ C C C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H / C DATA IFMT1(10) /1HA/, IFMT2(10) /1H / C DATA IFMT1(11) /1H1/, IFMT2(11) /1H(/ C DATA IFMT1(12) /1H,/, IFMT2(12) /1H3/ C DATA IFMT1(13) /1H /, IFMT2(13) /1HX/ C DATA IFMT1(14) /1H2/, IFMT2(14) /1H,/ C DATA IFMT1(15) /1HX/, IFMT2(15) /1H1/ C DATA IFMT1(16) /1H,/, IFMT2(16) /1HA/ C DATA IFMT1(17) /1H2/, IFMT2(17) /1H1/ C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/, IFMT2(19) /1H)/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/ DATA IFMT1(10) /'A'/, IFMT2(10) /' '/ DATA IFMT1(11) /'1'/, IFMT2(11) /'('/ DATA IFMT1(12) /','/, IFMT2(12) /'3'/ DATA IFMT1(13) /' '/, IFMT2(13) /'X'/ DATA IFMT1(14) /'2'/, IFMT2(14) /','/ DATA IFMT1(15) /'X'/, IFMT2(15) /'1'/ DATA IFMT1(16) /','/, IFMT2(16) /'A'/ DATA IFMT1(17) /'2'/, IFMT2(17) /'1'/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/, IFMT2(19) /')'/ DATA IFMT1(20) /')'/ C/ C C/6S C IF (NITEMS .LE. 0) CALL C 1 SETERR(27H APRNTL - NITEMS .LE. ZERO, 27, 1, 2) C/7S IF (NITEMS .LE. 0) CALL 1 SETERR(' APRNTL - NITEMS .LE. ZERO', 27, 1, 2) C/ C C COMPUTE THE NUMBER OF FIELDS OF 4 ACROSS A LINE. C NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160)-INDW)/4)) C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE 4-CHARACTER SPACE. CALL S88FMT(2, NCOL, IFMT2(9)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C 10 I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = FCHAR IF ( A(I) ) LINE(J) = TCHAR IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE APRNTR(A, NITEMS, IOUT, MCOL, W, D) C C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE REAL ARRAY, A, ON C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES. C THE OUTPUT FORMAT IS 1PEW.D. C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE. C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES. C C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982. C C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160. C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE() C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST C BE DIMENSIONED ACCORDINGLY. C C INPUT PARAMETERS - C C A - THE START OF THE REAL ARRAY TO BE PRINTED C C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED C C IOUT - THE OUTPUT UNIT FOR PRINTING C C MCOL - THE NUMBER OF SPACES ACROSS THE LINE C C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D) C C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D) C C C ERROR STATES - C C 1 - NITEMS .LE. ZERO C C 2 - W .GT. MCOL C C 3 - D .LT. ZERO C C 4 - W .LT. D+6 C INTEGER NITEMS, IOUT, MCOL, W, D REAL A(NITEMS) C INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX, 1 EXPENT, I1MACH, ICEIL, IABS, I10WID C/6S C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1)) C/7S CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR CHARACTER*20 IFMT1C CHARACTER*18 IFMT2C EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C) C/ INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST LOGICAL DUP REAL LINE(18), LAST(18), LOGETA C C/6S C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/ C/7S DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/ C/ C C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES C C/6S C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/ C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/ C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/ C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/ C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/ C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/ C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/ C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/ C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/ C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/ C DATA IFMT1(11) /1H1/, IFMT2(11) /1H / C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/ C DATA IFMT1(13) /1H /, IFMT2(13) /1H / C DATA IFMT1(14) /1H /, IFMT2(14) /1H / C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./ C DATA IFMT1(16) /1H,/, IFMT2(16) /1H / C DATA IFMT1(17) /1H2/, IFMT2(17) /1H / C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/ C DATA IFMT1(19) /1H1/ C DATA IFMT1(20) /1H)/ C/7S DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/ DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/ DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/ DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/ DATA IFMT1( 5) /','/, IFMT2( 5) /','/ DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/ DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/ DATA IFMT1( 8) /','/, IFMT2( 8) /','/ DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/ DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/ DATA IFMT1(11) /'1'/, IFMT2(11) /' '/ DATA IFMT1(12) /','/, IFMT2(12) /'E'/ DATA IFMT1(13) /' '/, IFMT2(13) /' '/ DATA IFMT1(14) /' '/, IFMT2(14) /' '/ DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/ DATA IFMT1(16) /','/, IFMT2(16) /' '/ DATA IFMT1(17) /'2'/, IFMT2(17) /' '/ DATA IFMT1(18) /'A'/, IFMT2(18) /')'/ DATA IFMT1(19) /'1'/ DATA IFMT1(20) /')'/ C/ C C/6S C IF (NITEMS .LE. 0) CALL C 1 SETERR(27H APRNTR - NITEMS .LE. ZERO, 27, 1, 2) C/7S IF (NITEMS .LE. 0) CALL 1 SETERR(' APRNTR - NITEMS .LE. ZERO', 27, 1, 2) C/ C C/6S C IF (W .GT. MCOL) CALL C 1 SETERR(22H APRNTR - W .GT. MCOL, 22, 2, 2) C/7S IF (W .GT. MCOL) CALL 1 SETERR(' APRNTR - W .GT. MCOL', 22, 2, 2) C/ C C/6S C IF (D .LT. 0) CALL C 1 SETERR(22H APRNTR - D .LT. ZERO, 22, 3, 2) C/7S IF (D .LT. 0) CALL 1 SETERR(' APRNTR - D .LT. ZERO', 22, 3, 2) C/ C C/6S C IF (W .LT. D+6) CALL C 1 SETERR(21H APRNTR - W .LT. D+6, 21, 4, 2) C/7S IF (W .LT. D+6) CALL 1 SETERR(' APRNTR - W .LT. D+6', 21, 4, 2) C/ C C C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED. C IF (EXPENT .GT. 0) GO TO 10 LOGETA = ALOG10(FLOAT(I1MACH(10))) EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1))) EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13))) EXPENT = I10WID(MAX0(EMIN, EMAX)) C C COMPUTE THE FORMATS. C 10 WW = MIN0(99, MAX0(W, 5+EXPENT)) CALL S88FMT(2, WW, IFMT2(13)) DD = MIN0(D, (WW-(5+EXPENT))) CALL S88FMT(2, DD, IFMT2(16)) C C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE. C NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW)) CALL S88FMT(1, NCOL, IFMT2(11)) WW = WW-2 C C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE. CALL S88FMT(2, WW, IFMT1(13)) C C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED, C J COUNTS THE NUMBER ON A GIVEN LINE, C COUNT COUNTS THE NUMBER OF DUPLICATE LINES. C I = 1 J = 0 COUNT = 0 C C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS - C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE- C FULL IS PUT INTO THE ARRAY, LINE. C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN C TO CHECK FOR REPEAT OR DUPLICATED LINES. C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION C COUNTER, COUNT, IS SET TO ONE. C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF C DUPLICATE LINES. C C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT C IN A LINE. C 20 IF (I .GT. NITEMS) GO TO 90 J = J+1 LINE(J) = A(I) IF (J .EQ. 1) ILINE = I IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80 IF (COUNT .EQ. 0) GO TO 50 DUP = .TRUE. DO 30 K=1,NCOL 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE. IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE. IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50 IF (.NOT. DUP) GO TO 40 COUNT = COUNT+1 IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK, 1 STAR, STAR, STAR, STAR IF (I .EQ. NITEMS) GO TO 50 GO TO 70 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL) 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J) COUNT = 1 DO 60 K=1,NCOL 60 LAST(K) = LINE(K) 70 ILAST = ILINE J = 0 80 I = I+1 GO TO 20 90 RETURN END SUBROUTINE C6LCF(P,X,NF,F,IU,UR,UF) INTEGER P,IU REAL X(P),F,UR EXTERNAL UF CALL UF(P,X,NF,F) RETURN END SUBROUTINE C7VFN(IV, L, LH, LIV, LV, N, P, V) C C *** FINISH COVARIANCE COMPUTATION FOR RN2G, RNSG *** C INTEGER LH, LIV, LV, N, P INTEGER IV(LIV) REAL L(LH), V(LV) C EXTERNAL L7NVR, L7TSQ, V7SCL C C *** LOCAL VARIABLES *** C INTEGER COV, I REAL HALF C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COVMAT, F, FDH, H, MODE, RDREQ, REGD C C/6 C DATA CNVCOD/55/, COVMAT/26/, F/10/, FDH/74/, H/56/, MODE/35/, C 1 RDREQ/57/, REGD/67/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, F=10, FDH=74, H=56, MODE=35, 1 RDREQ=57, REGD=67) C/ DATA HALF/0.5E+0/ C C *** BODY *** C IV(1) = IV(CNVCOD) I = IV(MODE) - P IV(MODE) = 0 IV(CNVCOD) = 0 IF (IV(FDH) .LE. 0) GO TO 999 IF ((I-2)**2 .EQ. 1) IV(REGD) = 1 IF (MOD(IV(RDREQ),2) .NE. 1) GO TO 999 C C *** FINISH COMPUTING COVARIANCE MATRIX = INVERSE OF F.D. HESSIAN. C COV = IABS(IV(H)) IV(FDH) = 0 C IF (IV(COVMAT) .NE. 0) GO TO 999 IF (I .GE. 2) GO TO 10 CALL L7NVR(P, V(COV), L) CALL L7TSQ(P, V(COV), V(COV)) C 10 CALL V7SCL(LH, V(COV), V(F)/(HALF * FLOAT(MAX0(1,N-P))), V(COV)) IV(COVMAT) = COV C 999 RETURN C *** LAST LINE OF C7VFN FOLLOWS *** END SUBROUTINE CDDIV(A,B,C) DOUBLE PRECISION A(2),B(2),C(2),G,H,T C C THIS ROUTINE DOES COMPLEX DOUBLE PRECISION C DIVISION (C=A/B), FOLLOWING THE METHOD C GIVEN IN ALGOL ON PAGES 357 AND 358 OF C WILKINSON AND REINSCHS BOOK- C HANDBOOK FOR AUTOMATIC COMPUTATION C SPRINGER-VERLAG 1971 C C THIS VERSION HAS BEEN CHANGED SLIGHTLY TO PREVENT C INPUTS A AND B FROM BEING DESTROYED. C WRITTEN MARCH 20, 1975 BY P. FOX C C FOR ACCURACY THE COMPUTATION IS DONE DIFFERENTLY C DEPENDING ON WHETHER THE REAL OR IMAGINARY PART OF C B IS LARGER C IF ( DABS(B(1)) .GT. DABS(B(2)) ) GO TO 10 H = B(1)/B(2) G = H*B(1) + B(2) T = A(1) C(1) = (H * T + A(2))/G C(2) = (H * A(2) - T)/G RETURN C C IF THE REAL PART OF B IS LARGER THAN THE IMAGINARY- 10 H = B(2)/B(1) G = H*B(2) + B(1) T = A(1) C(1) = ( T + H * A(2))/G C(2) = (A(2) - H * T)/G RETURN END SUBROUTINE D0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,RHG,EMAG, 1 ESAVE) C DOUBLE PRECISION TM(NVAR),NG(M),T(NVAR,KMAX),RHG(1) C DOUBLE PRECISION RHG(MIN(M-1,KMAX)) REAL ERROR(NVAR,1),EBEST(NVAR),EMAG(1) C REAL ERROR(NVAR,MIN(M-1,KMAX)),EMAG(MIN(M-1,KMAX)) LOGICAL XPOLY,ESAVE C DOUBLE PRECISION U,V,TI,TV,TEMP REAL ERR C IF (M.GT.1) GO TO 20 C C ... INITIALIZE T. C DO 10 I=1,NVAR 10 T(I,1)=TM(I) C GO TO 80 C 20 MR=MIN0(M-1,KMAX) C DO 30 J=1,MR MMJ=M-J RHG(J)=NG(M)/NG(MMJ) EMAG(J)=1.0D0+1.0D0/(RHG(J)-1.0D0) IF (XPOLY) RHG(J)=RHG(J)-1.0D0 30 CONTINUE C DO 70 I=1,NVAR C V=0.0D0 U=T(I,1) TI=TM(I) T(I,1)=TI C DO 60 J=1,MR C C ......... OBTAIN SIGNED ERROR ESTIMATE. C ERR=(T(I,J)-U)*EMAG(J) IF (ESAVE) ERROR(I,J)=ERR ERR=ABS(ERR) IF (J.EQ.1) EBEST(I)=ERR EBEST(I)=AMIN1(EBEST(I),ERR) IF (EBEST(I).EQ.ERR) JBEST=J C IF (J.EQ.KMAX) GO TO 60 C IF (XPOLY) GO TO 40 C C ......... RATIONAL EXTRAPOLATION. C TV=TI-V TEMP=RHG(J)*(U-V)-TV IF (TEMP.NE.0.0D0) TI=TI+(TI-U)*(TV/TEMP) V=U GO TO 50 C C ......... POLYNOMIAL EXTRAPOLATION. C 40 TI=TI+(TI-U)/RHG(J) C 50 U=T(I,J+1) T(I,J+1)=TI 60 CONTINUE C 70 TM(I)=T(I,JBEST) C 80 RETURN C END DOUBLE PRECISION FUNCTION D1MACH(I) INTEGER I C C DOUBLE-PRECISION MACHINE CONSTANTS C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. C D1MACH( 5) = LOG10(B) C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) INTEGER SC, CRAY1(38), J COMMON /D9MACH/ CRAY1 SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC DOUBLE PRECISION DMACH(5) EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR C MANY MACHINES YET. C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 C ON THE NEXT LINE DATA SC/0/ C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY C mail netlib@research.bell-labs.com C send old1mach from blas C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS. C DATA SMALL(1),SMALL(2) / 8388608, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / C DATA DIVER(1),DIVER(2) / 620756992, 0 / C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ C C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. IF (SC .NE. 987) THEN DMACH(1) = 1.D13 IF ( SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) THEN * *** IEEE BIG ENDIAN *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2146435071 LARGE(2) = -1 RIGHT(1) = 1017118720 RIGHT(2) = 0 DIVER(1) = 1018167296 DIVER(2) = 0 LOG10(1) = 1070810131 LOG10(2) = 1352628735 ELSE IF ( SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528) THEN * *** IEEE LITTLE ENDIAN *** SMALL(2) = 1048576 SMALL(1) = 0 LARGE(2) = 2146435071 LARGE(1) = -1 RIGHT(2) = 1017118720 RIGHT(1) = 0 DIVER(2) = 1018167296 DIVER(1) = 0 LOG10(2) = 1070810131 LOG10(1) = 1352628735 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** SMALL(1) = 128 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 9344 RIGHT(2) = 0 DIVER(1) = 9472 DIVER(2) = 0 LOG10(1) = 546979738 LOG10(2) = -805796613 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 856686592 RIGHT(2) = 0 DIVER(1) = 873463808 DIVER(2) = 0 LOG10(1) = 1091781651 LOG10(2) = 1352628735 ELSE IF ( SMALL(1) .EQ. 1120022684 * .AND. SMALL(2) .EQ. -448790528) THEN * *** CONVEX C-1 *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 1019215872 RIGHT(2) = 0 DIVER(1) = 1020264448 DIVER(2) = 0 LOG10(1) = 1072907283 LOG10(2) = 1352628735 ELSE IF ( SMALL(1) .EQ. 815547074 * .AND. SMALL(2) .EQ. 58688) THEN * *** VAX G-FLOATING *** SMALL(1) = 16 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 15552 RIGHT(2) = 0 DIVER(1) = 15568 DIVER(2) = 0 LOG10(1) = 1142112243 LOG10(2) = 2046775455 ELSE DMACH(2) = 1.D27 + 1 DMACH(3) = 1.D27 LARGE(2) = LARGE(2) - RIGHT(2) IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN CRAY1(1) = 67291416 DO 10 J = 1, 20 CRAY1(J+1) = CRAY1(J) + CRAY1(J) 10 CONTINUE CRAY1(22) = CRAY1(21) + 321322 DO 20 J = 22, 37 CRAY1(J+1) = CRAY1(J) + CRAY1(J) 20 CONTINUE IF (CRAY1(38) .EQ. SMALL(1)) THEN * *** CRAY *** CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) SMALL(2) = 0 CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) RIGHT(2) = 0 CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) DIVER(2) = 0 CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) ELSE WRITE(*,9000) STOP 779 END IF ELSE WRITE(*,9000) STOP 779 END IF END IF SC = 987 END IF * SANITY CHECK IF (DMACH(4) .GE. 1.0D0) STOP 778 IF (I .LT. 1 .OR. I .GT. 5) THEN WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' STOP END IF D1MACH = DMACH(I) RETURN 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ *' appropriate for your machine.') * /* Standard C source for D1MACH -- remove the * in column 1 */ *#include *#include *#include *double d1mach_(long *i) *{ * switch(*i){ * case 1: return DBL_MIN; * case 2: return DBL_MAX; * case 3: return DBL_EPSILON/FLT_RADIX; * case 4: return DBL_EPSILON; * case 5: return log10((double)FLT_RADIX); * } * fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); * exit(1); return 0; /* some compilers demand return values */ *} END SUBROUTINE I1MCRY(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END SUBROUTINE D4SQR(K, M, N, Q, R, B, RHS) INTEGER M INTEGER N REAL Q(K, 1), R( 1), B(1), RHS(K) INTEGER I REAL BETA, ALPHA,U, X C C THIS SUBROUTINE UPDATES THE QR DECOMPOSTION WHENE A NEW C ROW CONTAINED IN B IS ADDED TO THE MATRIX C M=M+1 MM1=M-1 C C ZERO OUT ROW AND COLUMN OF Q MATRIX C Q(M,M)=1. IF(M.EQ.1)RETURN DO 10 II=1,MM1 Q(M,II)=0.0 Q(II,M)=0.0 10 CONTINUE X=RHS(M) IF (N.EQ.0) RETURN IS=1 DO 20 I=1,N CALL SROTG(R(IS), B(I), ALPHA, BETA) CALL SROT(M, Q(I, 1), K, Q(M, 1), K, ALPHA, BETA) U=RHS(I) RHS(I)=ALPHA*U+BETA*X X=-BETA*U+ALPHA*X IS=IS+I+1 IF (N-I.GE.1) 1 CALL SROT2(N-I,R(IS-1),I+1,B(I+1),-1,ALPHA,BETA) 20 CONTINUE RHS(M)=X RETURN END SUBROUTINE D7DGB(B, D, DIG, DST, G, IPIV, KA, L, LV, P, PC, 1 NWTST, STEP, TD, TG, V, W, X0) C C *** COMPUTE DOUBLE-DOGLEG STEP, SUBJECT TO SIMPLE BOUNDS ON X *** C INTEGER LV, KA, P, PC INTEGER IPIV(P) REAL B(2,P), D(P), DIG(P), DST(P), G(P), L(1), 1 NWTST(P), STEP(P), TD(P), TG(P), V(LV), W(P), 2 X0(P) C C DIMENSION L(P*(P+1)/2) C REAL D7TPR, R7MDC, V2NRM EXTERNAL D7DOG, D7TPR, I7SHFT, L7ITV, L7IVM, L7TVM, L7VML, 1 Q7RSH, R7MDC, V2NRM, V2AXY, V7CPY, V7IPR, V7SCP, 2 V7SHF, V7VMP C C *** LOCAL VARIABLES *** C INTEGER I, J, K, P1, P1M1 REAL DNWTST, GHINVG, GNORM, GNORM0, NRED, PRED, RAD, 1 T, T1, T2, TI, X0I, XI REAL HALF, MEPS2, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER DGNORM, DST0, DSTNRM, GRDFAC, GTHG, GTSTEP, NREDUC, 1 NWTFAC, PREDUC, RADIUS, STPPAR C C/6 C DATA DGNORM/1/, DST0/3/, DSTNRM/2/, GRDFAC/45/, GTHG/44/, C 1 GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/, RADIUS/8/, C 2 STPPAR/5/ C/7 PARAMETER (DGNORM=1, DST0=3, DSTNRM=2, GRDFAC=45, GTHG=44, 1 GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, RADIUS=8, 2 STPPAR=5) C/ C/6 C DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ONE=1.E+0, TWO=2.E+0, ZERO=0.E+0) SAVE MEPS2 C/ DATA MEPS2/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (MEPS2 .LE. ZERO) MEPS2 = TWO * R7MDC(3) GNORM0 = V(DGNORM) V(DSTNRM) = ZERO IF (KA .LT. 0) GO TO 10 DNWTST = V(DST0) NRED = V(NREDUC) 10 PRED = ZERO V(STPPAR) = ZERO RAD = V(RADIUS) IF (PC .GT. 0) GO TO 20 DNWTST = ZERO CALL V7SCP(P, STEP, ZERO) GO TO 140 C 20 P1 = PC CALL V7CPY(P, TD, D) CALL V7IPR(P, IPIV, TD) CALL V7SCP(PC, DST, ZERO) CALL V7CPY(P, TG, G) CALL V7IPR(P, IPIV, TG) C 30 CALL L7IVM(P1, NWTST, L, TG) GHINVG = D7TPR(P1, NWTST, NWTST) V(NREDUC) = HALF * GHINVG CALL L7ITV(P1, NWTST, L, NWTST) CALL V7VMP(P1, STEP, NWTST, TD, 1) V(DST0) = V2NRM(PC, STEP) IF (KA .GE. 0) GO TO 40 KA = 0 DNWTST = V(DST0) NRED = V(NREDUC) 40 V(RADIUS) = RAD - V(DSTNRM) IF (V(RADIUS) .LE. ZERO) GO TO 100 CALL V7VMP(P1, DIG, TG, TD, -1) GNORM = V2NRM(P1, DIG) IF (GNORM .LE. ZERO) GO TO 100 V(DGNORM) = GNORM CALL V7VMP(P1, DIG, DIG, TD, -1) CALL L7TVM(P1, W, L, DIG) V(GTHG) = V2NRM(P1, W) KA = KA + 1 CALL D7DOG(DIG, LV, P1, NWTST, STEP, V) C C *** FIND T SUCH THAT X - T*STEP IS STILL FEASIBLE. C T = ONE K = 0 DO 70 I = 1, P1 J = IPIV(I) X0I = X0(J) + DST(I)/TD(I) XI = X0I + STEP(I) IF (XI .LT. B(1,J)) GO TO 50 IF (XI .LE. B(2,J)) GO TO 70 TI = (B(2,J) - X0I) / STEP(I) J = I GO TO 60 50 TI = (B(1,J) - X0I) / STEP(I) J = -I 60 IF (T .LE. TI) GO TO 70 K = J T = TI 70 CONTINUE C C *** UPDATE DST, TG, AND PRED *** C CALL V7VMP(P1, STEP, STEP, TD, 1) CALL V2AXY(P1, DST, T, STEP, DST) V(DSTNRM) = V2NRM(PC, DST) T1 = T * V(GRDFAC) T2 = T * V(NWTFAC) PRED = PRED - T1*GNORM * ((T2 + ONE)*GNORM) 1 - T2 * (ONE + HALF*T2)*GHINVG 2 - HALF * (V(GTHG)*T1)**2 IF (K .EQ. 0) GO TO 100 CALL L7VML(P1, W, L, W) T2 = ONE - T2 DO 80 I = 1, P1 80 TG(I) = T2*TG(I) - T1*W(I) C C *** PERMUTE L, ETC. IF NECESSARY *** C P1M1 = P1 - 1 J = IABS(K) IF (J .EQ. P1) GO TO 90 CALL Q7RSH(J, P1, .FALSE., TG, L, W) CALL I7SHFT(P1, J, IPIV) CALL V7SHF(P1, J, TG) CALL V7SHF(P1, J, TD) CALL V7SHF(P1, J, DST) 90 IF (K .LT. 0) IPIV(P1) = -IPIV(P1) P1 = P1M1 IF (P1 .GT. 0) GO TO 30 C C *** UNSCALE STEP, UPDATE X AND DIHDI *** C 100 CALL V7SCP(P, STEP, ZERO) DO 110 I = 1, PC J = IABS(IPIV(I)) STEP(J) = DST(I) / TD(I) 110 CONTINUE C C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS C *** TO THEIR BOUNDS *** C IF (P1 .GE. PC) GO TO 140 CALL V2AXY(P, TD, ONE, STEP, X0) K = P1 + 1 DO 130 I = K, PC J = IPIV(I) T = MEPS2 IF (J .GT. 0) GO TO 120 T = -T J = -J IPIV(I) = J 120 T = T * AMAX1( ABS(TD(J)), ABS(X0(J))) STEP(J) = STEP(J) + T 130 CONTINUE C 140 V(DGNORM) = GNORM0 V(NREDUC) = NRED V(PREDUC) = PRED V(RADIUS) = RAD V(DST0) = DNWTST V(GTSTEP) = D7TPR(P, STEP, G) C 999 RETURN C *** LAST LINE OF D7DGB FOLLOWS *** END SUBROUTINE D7DOG(DIG, LV, N, NWTSTP, STEP, V) C C *** COMPUTE DOUBLE DOGLEG STEP *** C C *** PARAMETER DECLARATIONS *** C INTEGER LV, N REAL DIG(N), NWTSTP(N), STEP(N), V(LV) C C *** PURPOSE *** C C THIS SUBROUTINE COMPUTES A CANDIDATE STEP (FOR USE IN AN UNCON- C STRAINED MINIMIZATION CODE) BY THE DOUBLE DOGLEG ALGORITHM OF C DENNIS AND MEI (REF. 1), WHICH IS A VARIATION ON POWELL*S DOGLEG C SCHEME (REF. 2, P. 95). C C-------------------------- PARAMETER USAGE -------------------------- C C DIG (INPUT) DIAG(D)**-2 * G -- SEE ALGORITHM NOTES. C G (INPUT) THE CURRENT GRADIENT VECTOR. C LV (INPUT) LENGTH OF V. C N (INPUT) NUMBER OF COMPONENTS IN DIG, G, NWTSTP, AND STEP. C NWTSTP (INPUT) NEGATIVE NEWTON STEP -- SEE ALGORITHM NOTES. C STEP (OUTPUT) THE COMPUTED STEP. C V (I/O) VALUES ARRAY, THE FOLLOWING COMPONENTS OF WHICH ARE C USED HERE... C V(BIAS) (INPUT) BIAS FOR RELAXED NEWTON STEP, WHICH IS V(BIAS) OF C THE WAY FROM THE FULL NEWTON TO THE FULLY RELAXED NEWTON C STEP. RECOMMENDED VALUE = 0.8 . C V(DGNORM) (INPUT) 2-NORM OF DIAG(D)**-1 * G -- SEE ALGORITHM NOTES. C V(DSTNRM) (OUTPUT) 2-NORM OF DIAG(D) * STEP, WHICH IS V(RADIUS) C UNLESS V(STPPAR) = 0 -- SEE ALGORITHM NOTES. C V(DST0) (INPUT) 2-NORM OF DIAG(D) * NWTSTP -- SEE ALGORITHM NOTES. C V(GRDFAC) (OUTPUT) THE COEFFICIENT OF DIG IN THE STEP RETURNED -- C STEP(I) = V(GRDFAC)*DIG(I) + V(NWTFAC)*NWTSTP(I). C V(GTHG) (INPUT) SQUARE-ROOT OF (DIG**T) * (HESSIAN) * DIG -- SEE C ALGORITHM NOTES. C V(GTSTEP) (OUTPUT) INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE FULL NEWTON C STEP. C V(NWTFAC) (OUTPUT) THE COEFFICIENT OF NWTSTP IN THE STEP RETURNED -- C SEE V(GRDFAC) ABOVE. C V(PREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE STEP RETURNED. C V(RADIUS) (INPUT) THE TRUST REGION RADIUS. D TIMES THE STEP RETURNED C HAS 2-NORM V(RADIUS) UNLESS V(STPPAR) = 0. C V(STPPAR) (OUTPUT) CODE TELLING HOW STEP WAS COMPUTED... 0 MEANS A C FULL NEWTON STEP. BETWEEN 0 AND 1 MEANS V(STPPAR) OF THE C WAY FROM THE NEWTON TO THE RELAXED NEWTON STEP. BETWEEN C 1 AND 2 MEANS A TRUE DOUBLE DOGLEG STEP, V(STPPAR) - 1 OF C THE WAY FROM THE RELAXED NEWTON TO THE CAUCHY STEP. C GREATER THAN 2 MEANS 1 / (V(STPPAR) - 1) TIMES THE CAUCHY C STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C LET G AND H BE THE CURRENT GRADIENT AND HESSIAN APPROXIMA- C TION RESPECTIVELY AND LET D BE THE CURRENT SCALE VECTOR. THIS C ROUTINE ASSUMES DIG = DIAG(D)**-2 * G AND NWTSTP = H**-1 * G. C THE STEP COMPUTED IS THE SAME ONE WOULD GET BY REPLACING G AND H C BY DIAG(D)**-1 * G AND DIAG(D)**-1 * H * DIAG(D)**-1, C COMPUTING STEP, AND TRANSLATING STEP BACK TO THE ORIGINAL C VARIABLES, I.E., PREMULTIPLYING IT BY DIAG(D)**-1. C C *** REFERENCES *** C C 1. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI- C MIZATION ALGORITHMS WHICH USE FUNCTION AND GRADIENT C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482. C 2. POWELL, M.J.D. (1970), A HYBRID METHOD FOR NON-LINEAR EQUATIONS, C IN NUMERICAL METHODS FOR NON-LINEAR EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I REAL CFACT, CNORM, CTRNWT, GHINVG, FEMNSQ, GNORM, 1 NWTNRM, RELAX, RLAMBD, T, T1, T2 REAL HALF, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER BIAS, DGNORM, DSTNRM, DST0, GRDFAC, GTHG, GTSTEP, 1 NREDUC, NWTFAC, PREDUC, RADIUS, STPPAR C C *** DATA INITIALIZATIONS *** C C/6 C DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ONE=1.E+0, TWO=2.E+0, ZERO=0.E+0) C/ C C/6 C DATA BIAS/43/, DGNORM/1/, DSTNRM/2/, DST0/3/, GRDFAC/45/, C 1 GTHG/44/, GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/, C 2 RADIUS/8/, STPPAR/5/ C/7 PARAMETER (BIAS=43, DGNORM=1, DSTNRM=2, DST0=3, GRDFAC=45, 1 GTHG=44, GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, 2 RADIUS=8, STPPAR=5) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NWTNRM = V(DST0) RLAMBD = ONE IF (NWTNRM .GT. ZERO) RLAMBD = V(RADIUS) / NWTNRM GNORM = V(DGNORM) GHINVG = TWO * V(NREDUC) V(GRDFAC) = ZERO V(NWTFAC) = ZERO IF (RLAMBD .LT. ONE) GO TO 30 C C *** THE NEWTON STEP IS INSIDE THE TRUST REGION *** C V(STPPAR) = ZERO V(DSTNRM) = NWTNRM V(GTSTEP) = -GHINVG V(PREDUC) = V(NREDUC) V(NWTFAC) = -ONE DO 20 I = 1, N 20 STEP(I) = -NWTSTP(I) GO TO 999 C 30 V(DSTNRM) = V(RADIUS) CFACT = (GNORM / V(GTHG))**2 C *** CAUCHY STEP = -CFACT * G. CNORM = GNORM * CFACT RELAX = ONE - V(BIAS) * (ONE - GNORM*CNORM/GHINVG) IF (RLAMBD .LT. RELAX) GO TO 50 C C *** STEP IS BETWEEN RELAXED NEWTON AND FULL NEWTON STEPS *** C V(STPPAR) = ONE - (RLAMBD - RELAX) / (ONE - RELAX) T = -RLAMBD V(GTSTEP) = T * GHINVG V(PREDUC) = RLAMBD * (ONE - HALF*RLAMBD) * GHINVG V(NWTFAC) = T DO 40 I = 1, N 40 STEP(I) = T * NWTSTP(I) GO TO 999 C 50 IF (CNORM .LT. V(RADIUS)) GO TO 70 C C *** THE CAUCHY STEP LIES OUTSIDE THE TRUST REGION -- C *** STEP = SCALED CAUCHY STEP *** C T = -V(RADIUS) / GNORM V(GRDFAC) = T V(STPPAR) = ONE + CNORM / V(RADIUS) V(GTSTEP) = -V(RADIUS) * GNORM V(PREDUC) = V(RADIUS)*(GNORM - HALF*V(RADIUS)*(V(GTHG)/GNORM)**2) DO 60 I = 1, N 60 STEP(I) = T * DIG(I) GO TO 999 C C *** COMPUTE DOGLEG STEP BETWEEN CAUCHY AND RELAXED NEWTON *** C *** FEMUR = RELAXED NEWTON STEP MINUS CAUCHY STEP *** C 70 CTRNWT = CFACT * RELAX * GHINVG / GNORM C *** CTRNWT = INNER PROD. OF CAUCHY AND RELAXED NEWTON STEPS, C *** SCALED BY GNORM**-1. T1 = CTRNWT - GNORM*CFACT**2 C *** T1 = INNER PROD. OF FEMUR AND CAUCHY STEP, SCALED BY C *** GNORM**-1. T2 = V(RADIUS)*(V(RADIUS)/GNORM) - GNORM*CFACT**2 T = RELAX * NWTNRM FEMNSQ = (T/GNORM)*T - CTRNWT - T1 C *** FEMNSQ = SQUARE OF 2-NORM OF FEMUR, SCALED BY GNORM**-1. T = T2 / (T1 + SQRT(T1**2 + FEMNSQ*T2)) C *** DOGLEG STEP = CAUCHY STEP + T * FEMUR. T1 = (T - ONE) * CFACT V(GRDFAC) = T1 T2 = -T * RELAX V(NWTFAC) = T2 V(STPPAR) = TWO - T V(GTSTEP) = T1*GNORM**2 + T2*GHINVG V(PREDUC) = -T1*GNORM * ((T2 + ONE)*GNORM) 1 - T2 * (ONE + HALF*T2)*GHINVG 2 - HALF * (V(GTHG)*T1)**2 DO 80 I = 1, N 80 STEP(I) = T1*DIG(I) + T2*NWTSTP(I) C 999 RETURN C *** LAST LINE OF D7DOG FOLLOWS *** END SUBROUTINE D7DUP(D, HDIAG, IV, LIV, LV, N, V) C C *** UPDATE SCALE VECTOR D FOR MNH *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N INTEGER IV(LIV) REAL D(N), HDIAG(N), V(LV) C C *** LOCAL VARIABLES *** C INTEGER DTOLI, D0I, I REAL T, VDFAC C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTOL, DTYPE, NITER C/6 C DATA DFAC/41/, DTOL/59/, DTYPE/16/, NITER/31/ C/7 PARAMETER (DFAC=41, DTOL=59, DTYPE=16, NITER=31) C/ C C------------------------------- BODY -------------------------------- C I = IV(DTYPE) IF (I .EQ. 1) GO TO 10 IF (IV(NITER) .GT. 0) GO TO 999 C 10 DTOLI = IV(DTOL) D0I = DTOLI + N VDFAC = V(DFAC) DO 20 I = 1, N T = AMAX1( SQRT( ABS(HDIAG(I))), VDFAC*D(I)) IF (T .LT. V(DTOLI)) T = AMAX1(V(DTOLI), V(D0I)) D(I) = T DTOLI = DTOLI + 1 D0I = D0I + 1 20 CONTINUE C 999 RETURN C *** LAST CARD OF D7DUP FOLLOWS *** END SUBROUTINE D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA,BWA) INTEGER N INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),IWA(N) LOGICAL BWA(N) C ********** C C SUBROUTINE D7EGR C C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, C THIS SUBROUTINE DETERMINES THE DEGREE SEQUENCE FOR C THE INTERSECTION GRAPH OF THE COLUMNS OF A. C C IN GRAPH-THEORY TERMINOLOGY, THE INTERSECTION GRAPH OF C THE COLUMNS OF A IS THE LOOPLESS GRAPH G WITH VERTICES C A(J), J = 1,2,...,N WHERE A(J) IS THE J-TH COLUMN OF A C AND WITH EDGE (A(I),A(J)) IF AND ONLY IF COLUMNS I AND J C HAVE A NON-ZERO IN THE SAME ROW POSITION. C C NOTE THAT THE VALUE OF M IS NOT NEEDED BY D7EGR AND IS C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA,BWA) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW C INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. C THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. C THE COLUMN INDICES FOR ROW I ARE C C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. C C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C NDEG IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH C SPECIFIES THE DEGREE SEQUENCE. THE DEGREE OF THE C J-TH COLUMN OF A IS NDEG(J). C C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. C C BWA IS A LOGICAL WORK ARRAY OF LENGTH N. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER DEG,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU C C INITIALIZATION BLOCK. C DO 10 JP = 1, N NDEG(JP) = 0 BWA(JP) = .FALSE. 10 CONTINUE C C COMPUTE THE DEGREE SEQUENCE BY DETERMINING THE CONTRIBUTIONS C TO THE DEGREES FROM THE CURRENT(JCOL) COLUMN AND FURTHER C COLUMNS WHICH HAVE NOT YET BEEN CONSIDERED. C IF (N .LT. 2) GO TO 90 DO 80 JCOL = 2, N BWA(JCOL) = .TRUE. DEG = 0 C C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND C TO NON-ZEROES IN THE MATRIX. C JPL = JPNTR(JCOL) JPU = JPNTR(JCOL+1) - 1 IF (JPU .LT. JPL) GO TO 50 DO 40 JP = JPL, JPU IR = INDROW(JP) C C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. C IPL = IPNTR(IR) IPU = IPNTR(IR+1) - 1 DO 30 IP = IPL, IPU IC = INDCOL(IP) C C ARRAY BWA MARKS COLUMNS WHICH HAVE CONTRIBUTED TO C THE DEGREE COUNT OF COLUMN JCOL. UPDATE THE DEGREE C COUNTS OF THESE COLUMNS. ARRAY IWA RECORDS THE C MARKED COLUMNS. C IF (BWA(IC)) GO TO 20 BWA(IC) = .TRUE. NDEG(IC) = NDEG(IC) + 1 DEG = DEG + 1 IWA(DEG) = IC 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE C C UN-MARK THE COLUMNS RECORDED BY IWA AND FINALIZE THE C DEGREE COUNT OF COLUMN JCOL. C IF (DEG .LT. 1) GO TO 70 DO 60 JP = 1, DEG IC = IWA(JP) BWA(IC) = .FALSE. 60 CONTINUE NDEG(JCOL) = NDEG(JCOL) + DEG 70 CONTINUE 80 CONTINUE 90 CONTINUE RETURN C C LAST CARD OF SUBROUTINE D7EGR. C END SUBROUTINE D7MLP(N, X, Y, Z, K) C C *** SET X = DIAG(Y)**K * Z C *** FOR X, Z = LOWER TRIANG. MATRICES STORED COMPACTLY BY ROW C *** K = 1 OR -1. C INTEGER N, K C/6 C REAL X(1), Y(N), Z(1) C/7 REAL X(*), Y(N), Z(*) C/ INTEGER I, J, L REAL ONE, T DATA ONE/1.E+0/ C L = 1 IF (K .GE. 0) GO TO 30 DO 20 I = 1, N T = ONE / Y(I) DO 10 J = 1, I X(L) = T * Z(L) L = L + 1 10 CONTINUE 20 CONTINUE GO TO 999 C 30 DO 50 I = 1, N T = Y(I) DO 40 J = 1, I X(L) = T * Z(L) L = L + 1 40 CONTINUE 50 CONTINUE 999 RETURN C *** LAST CARD OF D7MLP FOLLOWS *** END REAL FUNCTION D7TPR(P, X, Y) C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C INTEGER P REAL X(P), Y(P) C INTEGER I REAL ONE, SQTETA, T, ZERO REAL R7MDC EXTERNAL R7MDC C C *** R7MDC(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C C/6 C DATA ONE/1.E+0/, SQTETA/0.E+0/, ZERO/0.E+0/ C/7 PARAMETER (ONE=1.E+0, ZERO=0.E+0) DATA SQTETA/0.E+0/ C/ C D7TPR = ZERO IF (P .LE. 0) GO TO 999 IF (SQTETA .EQ. ZERO) SQTETA = R7MDC(2) DO 20 I = 1, P T = AMAX1( ABS(X(I)), ABS(Y(I))) IF (T .GT. ONE) GO TO 10 IF (T .LT. SQTETA) GO TO 20 T = (X(I)/SQTETA)*Y(I) IF ( ABS(T) .LT. SQTETA) GO TO 20 10 D7TPR = D7TPR + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST LINE OF D7TPR FOLLOWS *** END SUBROUTINE D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** UPDATE SCALE VECTOR D FOR NL2IT *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N, ND, NN, N2, P INTEGER IV(LIV) REAL D(P), DR(ND,P), V(LV) C DIMENSION V(*) C C *** LOCAL VARIABLES *** C INTEGER D0, I, JCN0, JCN1, JCNI, JTOL0, JTOLI, K, SII REAL T, VDFAC C C *** CONSTANTS *** C REAL ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C *** EXTERNAL SUBROUTINE *** C EXTERNAL V7SCP C C V7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTYPE, JCN, JTOL, NITER, S C/6 C DATA DFAC/41/, DTYPE/16/, JCN/66/, JTOL/59/, NITER/31/, S/62/ C/7 PARAMETER (DFAC=41, DTYPE=16, JCN=66, JTOL=59, NITER=31, S=62) C/ C C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C C------------------------------- BODY -------------------------------- C IF (IV(DTYPE) .NE. 1 .AND. IV(NITER) .GT. 0) GO TO 999 JCN1 = IV(JCN) JCN0 = IABS(JCN1) - 1 IF (JCN1 .LT. 0) GO TO 10 IV(JCN) = -JCN1 CALL V7SCP(P, V(JCN1), ZERO) 10 DO 30 I = 1, P JCNI = JCN0 + I T = V(JCNI) DO 20 K = 1, NN 20 T = AMAX1(T, ABS(DR(K,I))) V(JCNI) = T 30 CONTINUE IF (N2 .LT. N) GO TO 999 VDFAC = V(DFAC) JTOL0 = IV(JTOL) - 1 D0 = JTOL0 + P SII = IV(S) - 1 DO 50 I = 1, P SII = SII + I JCNI = JCN0 + I T = V(JCNI) IF (V(SII) .GT. ZERO) T = AMAX1( SQRT(V(SII)), T) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = AMAX1(V(D0), V(JTOLI)) D(I) = AMAX1(VDFAC*D(I), T) 50 CONTINUE C 999 RETURN C *** LAST CARD OF D7UPD FOLLOWS *** END SUBROUTINE DA7SST(IV, LIV, LV, V) C C *** ASSESS CANDIDATE STEP (***SOL VERSION 2.3) *** C INTEGER LIV, LV INTEGER IV(LIV) DOUBLE PRECISION V(LV) C C *** PURPOSE *** C C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM- C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING C BELOW. C C-------------------------- PARAMETER USAGE -------------------------- C C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF IV VALUES REFERENCED. C LIV (IN) LENGTH OF IV ARRAY. C LV (IN) LENGTH OF V ARRAY. C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF V VALUES REFERENCED. C C *** IV VALUES REFERENCED *** C C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION, C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE C UNCHANGED SINCE THE PREVIOUS RETURN OF DA7SST. C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE C FOLLOWING VALUES... C 1 = SWITCH MODELS OR TRY SMALLER STEP. C 2 = SWITCH MODELS OR ACCEPT STEP. C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT C TESTS. C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED. C 5 = RECOMPUTE STEP (USING THE SAME MODEL). C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT C EVALUATE THE OBJECTIVE FUNCTION. C 7 = X-CONVERGENCE (SEE V(XCTOL)). C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)). C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE. C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)). C 11 = SINGULAR CONVERGENCE (SEE V(LMAXS)). C 12 = FALSE CONVERGENCE (SEE V(XFTOL)). C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT. C RETURN CODE I HAS PRECEDENCE OVER I+1 FOR I = 9, 10, 11. C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL). C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION. C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION, C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT. C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION. C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED. C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER C OF DECREASES) SO FAR THIS ITERATION. C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE C RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED, C TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO C 0 OTHERWISE. C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE C CURRENT ITERATION. C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER. C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL, C IN WHICH CASE DA7SST SETS IV(SWITCH) = 1. C IV(TOOBIG) (I/O) IS NONZERO ON INPUT IF STEP WAS TOO BIG (E.G., IF C IT WOULD CAUSE OVERFLOW). IT IS SET TO 0 ON RETURN. C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS. C C *** V VALUES REFERENCED *** C C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS C THAN V(AFCTOL) AND DA7SST DOES NOT RETURN WITH C IV(IRC) = 11, THEN DA7SST RETURNS WITH IV(IRC) = 10. C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS C NONZERO. C V(DSTNRM) (IN) THE 2-NORM OF D*STEP. C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP. C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED, C I.E., FOR V(NREDUC) .GE. 0). C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC- C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE, C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE. C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE). C V(FLSTGD) (I/O) SAVED VALUE OF V(F). C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION. C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP. C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT. C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS. C V(LMAXS) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND). C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9 C DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT C STEP IS A NEWTON STEP, AND IF C V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN DA7SST RETURNS C WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, THEN C DA7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP) C WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS) C (BY A RETURN WITH IV(IRC) = 6). C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C NEWTON STEP. IF DA7SST IS CALLED WITH IV(IRC) = 6, I.E., C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR C USE IN THE SINGULAR CONVERGENCE TEST, THEN V(NREDUC) IS C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED. C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP. C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C CURRENT STEP. C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS, C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED. C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1. C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0. C V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED C (E.G.) BY FUNCTION DRLDST AS C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P). C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE- C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN C DA7SST RETURNS WITH IV(IRC) = 8 OR 9. C V(SCTOL) (IN) SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS). C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP. C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED C VALUE = 0.1. C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED C VALUE = 10**-4. C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75. C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN C DA7SST RETURNS IV(IRC) = 7 OR 9. C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL), C THEN DA7SST RETURNS WITH IV(IRC) = 12. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER, C OR LEVENBERG-MARQUARDT STEPS. C C *** ALGORITHM NOTES *** C C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS, C DA7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS. C C *** USAGE NOTES *** C C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O C VALUES EXCEPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER- C ANCES SHOULD BE CHANGED. C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN C CHANGE THE STOPPING TOLERANCES AND CALL DA7SST AGAIN, IN WHICH C CASE THE STOPPING TESTS WILL BE REPEATED. C C *** REFERENCES *** C C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3. C C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** HISTORY *** C C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY. C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS C PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR C CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** NO EXTERNAL FUNCTIONS AND SUBROUTINES *** C C-------------------------- LOCAL VARIABLES -------------------------- C LOGICAL GOODX INTEGER I, NFC DOUBLE PRECISION EMAX, EMAXS, GTS, RFAC1, XMAX DOUBLE PRECISION HALF, ONE, ONEP2, TWO, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0, 1 GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL, 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN, 3 RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM, 4 STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, 5 XFTOL, XIRC C C *** DATA INITIALIZATIONS *** C C/6 C DATA HALF/0.5D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, TWO/2.D+0/, C 1 ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ONE=1.D+0, ONEP2=1.2D+0, TWO=2.D+0, 1 ZERO=0.D+0) C/ C C/6 C DATA IRC/29/, MLSTGD/32/, MODEL/5/, NFCALL/6/, NFGCAL/7/, C 1 RADINC/8/, RESTOR/9/, STAGE/10/, STGLIM/11/, SWITCH/12/, C 2 TOOBIG/2/, XIRC/13/ C/7 PARAMETER (IRC=29, MLSTGD=32, MODEL=5, NFCALL=6, NFGCAL=7, 1 RADINC=8, RESTOR=9, STAGE=10, STGLIM=11, SWITCH=12, 2 TOOBIG=2, XIRC=13) C/ C/6 C DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, DSTSAV/18/, C 1 F/10/, FDIF/11/, FLSTGD/12/, F0/13/, GTSLST/14/, GTSTEP/4/, C 2 INCFAC/23/, LMAXS/36/, NREDUC/6/, PLSTGD/15/, PREDUC/7/, C 3 RADFAC/16/, RDFCMN/24/, RDFCMX/25/, RELDX/17/, RFCTOL/32/, C 4 SCTOL/37/, STPPAR/5/, TUNER1/26/, TUNER2/27/, TUNER3/28/, C 5 XCTOL/33/, XFTOL/34/ C/7 PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, DSTSAV=18, 1 F=10, FDIF=11, FLSTGD=12, F0=13, GTSLST=14, GTSTEP=4, 2 INCFAC=23, LMAXS=36, NREDUC=6, PLSTGD=15, PREDUC=7, 3 RADFAC=16, RDFCMN=24, RDFCMX=25, RELDX=17, RFCTOL=32, 4 SCTOL=37, STPPAR=5, TUNER1=26, TUNER2=27, TUNER3=28, 5 XCTOL=33, XFTOL=34) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NFC = IV(NFCALL) IV(SWITCH) = 0 IV(RESTOR) = 0 RFAC1 = ONE GOODX = .TRUE. I = IV(IRC) IF (I .GE. 1 .AND. I .LE. 12) 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 110 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 110 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILITY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 110, 110, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IV(TOOBIG) = 0 IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 IV(TOOBIG) = 0 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 IV(RESTOR) = 1 V(F) = V(FLSTGD) GO TO 999 C 70 IF (V(F) .LT. V(FLSTGD)) GO TO 110 C C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. *** C IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80 IV(MODEL) = IV(MLSTGD) IV(SWITCH) = 1 C C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F). C 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 110 IF (IV(STAGE) .LT. IV(STGLIM)) THEN GOODX = .FALSE. ELSE IF (NFC .LT. IV(NFGCAL) + IV(STGLIM) + 2) THEN GOODX = .FALSE. ELSE IF (IV(SWITCH) .NE. 0) THEN GOODX = .FALSE. ENDIF IV(RESTOR) = 3 V(F) = V(FLSTGD) V(PREDUC) = V(PLSTGD) V(GTSTEP) = V(GTSLST) IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV) V(DSTNRM) = V(DSTSAV) IF (GOODX) THEN C C *** ACCEPT PREVIOUS SLIGHTLY REDUCING STEP *** C V(FDIF) = V(F0) - V(F) IV(IRC) = 4 V(RADFAC) = RFAC1 GO TO 999 ENDIF NFC = IV(NFGCAL) C 110 V(FDIF) = V(F0) - V(F) IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 140 IF (IV(RADINC) .GT. 0) GO TO 140 C C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE C *** -- SO TRY NEW MODEL OR SMALLER RADIUS C IF (V(F) .LT. V(F0)) GO TO 120 IV(MLSTGD) = IV(MODEL) V(FLSTGD) = V(F) V(F) = V(F0) IV(RESTOR) = 1 GO TO 130 120 IV(NFGCAL) = NFC 130 IV(IRC) = 1 IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 160 IV(IRC) = 5 IV(RADINC) = IV(RADINC) - 1 GO TO 160 C C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED *** C 140 IV(NFGCAL) = NFC RFAC1 = ONE V(DSTSAV) = V(DSTNRM) IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 190 C C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS C *** OR ACCEPT STEP WITH DECREASED RADIUS. C IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 150 C *** CONSIDER SWITCHING MODELS *** IV(IRC) = 2 GO TO 160 C C *** ACCEPT STEP WITH DECREASED RADIUS *** C 150 IV(IRC) = 4 C C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR *** C 160 IV(XIRC) = IV(IRC) EMAX = V(GTSTEP) + V(FDIF) V(RADFAC) = HALF * RFAC1 IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * DMAX1(V(RDFCMN), 1 HALF * V(GTSTEP)/EMAX) C C *** DO FALSE CONVERGENCE TEST *** C 170 IF (V(RELDX) .LE. V(XFTOL)) GO TO 180 IV(IRC) = IV(XIRC) IF (V(F) .LT. V(F0)) GO TO 200 GO TO 230 C 180 IV(IRC) = 12 GO TO 240 C C *** HANDLE GOOD FUNCTION DECREASE *** C 190 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 210 C C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS. C IF (IV(RADINC) .LT. 0) GO TO 210 IF (IV(RESTOR) .EQ. 1) GO TO 210 IF (IV(RESTOR) .EQ. 3) GO TO 210 C C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON C *** STEP. C V(RADFAC) = V(RDFCMX) GTS = V(GTSTEP) IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS) 1 V(RADFAC) = DMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF))) IV(IRC) = 4 IF (V(STPPAR) .EQ. ZERO) GO TO 230 IF (V(DST0) .GE. ZERO .AND. (V(DST0) .LT. TWO*V(DSTNRM) 1 .OR. V(NREDUC) .LT. ONEP2*V(FDIF))) GO TO 230 C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH C *** A LARGER RADIUS. IV(IRC) = 5 IV(RADINC) = IV(RADINC) + 1 C C *** SAVE VALUES CORRESPONDING TO GOOD STEP *** C 200 V(FLSTGD) = V(F) IV(MLSTGD) = IV(MODEL) IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 230 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 210 V(RADFAC) = ONE IV(IRC) = 3 GO TO 230 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 220 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 240 IV(IRC) = 12 GO TO 240 C C *** PERFORM CONVERGENCE TESTS *** C 230 IV(XIRC) = IV(IRC) 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3 IF (DABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = V(RFCTOL) * DABS(V(F0)) EMAXS = V(SCTOL) * DABS(V(F0)) IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR. 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 250 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL) 1 .AND. GOODX) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR C *** CONVERGENCE TEST. C 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(STPPAR) .EQ. ZERO) GO TO 999 IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260 IF (V(PREDUC) .GE. EMAXS) GO TO 999 IF (V(DST0) .LE. ZERO) GO TO 270 IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999 GO TO 270 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999 XMAX = V(LMAXS) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999 270 IF (V(NREDUC) .LT. ZERO) GO TO 290 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) I = IV(RESTOR) IV(RESTOR) = 2 IF (I .EQ. 3) IV(RESTOR) = 0 IV(IRC) = 6 GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 280 V(GTSTEP) = V(GTSLST) V(DSTNRM) = DABS(V(DSTSAV)) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) IV(RESTOR) = 3 290 IF (-V(NREDUC) .LE. V(SCTOL) * DABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST LINE OF DA7SST FOLLOWS *** END SUBROUTINE DALLOC(N) C CALL I0TK01 CALL ISTKRL(N) C RETURN C END SUBROUTINE DC6LCF(P,X,NF,F,IU,UR,UF) INTEGER P,IU DOUBLE PRECISION X(P),F,UR EXTERNAL UF CALL UF(P,X,NF,F) RETURN END SUBROUTINE DC7VFN(IV, L, LH, LIV, LV, N, P, V) C C *** FINISH COVARIANCE COMPUTATION FOR DRN2G, DRNSG *** C INTEGER LH, LIV, LV, N, P INTEGER IV(LIV) DOUBLE PRECISION L(LH), V(LV) C EXTERNAL DL7NVR, DL7TSQ, DV7SCL C C *** LOCAL VARIABLES *** C INTEGER COV, I DOUBLE PRECISION HALF C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COVMAT, F, FDH, H, MODE, RDREQ, REGD C C/6 C DATA CNVCOD/55/, COVMAT/26/, F/10/, FDH/74/, H/56/, MODE/35/, C 1 RDREQ/57/, REGD/67/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, F=10, FDH=74, H=56, MODE=35, 1 RDREQ=57, REGD=67) C/ DATA HALF/0.5D+0/ C C *** BODY *** C IV(1) = IV(CNVCOD) I = IV(MODE) - P IV(MODE) = 0 IV(CNVCOD) = 0 IF (IV(FDH) .LE. 0) GO TO 999 IF ((I-2)**2 .EQ. 1) IV(REGD) = 1 IF (MOD(IV(RDREQ),2) .NE. 1) GO TO 999 C C *** FINISH COMPUTING COVARIANCE MATRIX = INVERSE OF F.D. HESSIAN. C COV = IABS(IV(H)) IV(FDH) = 0 C IF (IV(COVMAT) .NE. 0) GO TO 999 IF (I .GE. 2) GO TO 10 CALL DL7NVR(P, V(COV), L) CALL DL7TSQ(P, V(COV), V(COV)) C 10 CALL DV7SCL(LH, V(COV), V(F)/(HALF * FLOAT(MAX0(1,N-P))), V(COV)) IV(COVMAT) = COV C 999 RETURN C *** LAST LINE OF DC7VFN FOLLOWS *** END SUBROUTINE DD4SQR(K, M, N, Q, R, B, RHS) INTEGER M INTEGER N DOUBLE PRECISION Q(K, 1), R( 1), B(1), RHS(K) INTEGER I DOUBLE PRECISION BETA, ALPHA,U, X C C THIS SUBROUTINE UPDATES THE QR DECOMPOSTION WHENE A NEW C ROW CONTAINED IN B IS ADDED TO THE MATRIX C M=M+1 MM1=M-1 C C ZERO OUT ROW AND COLUMN OF Q MATRIX C Q(M,M)=1. IF(M.EQ.1)RETURN DO 10 II=1,MM1 Q(M,II)=0.0D0 Q(II,M)=0.0D0 10 CONTINUE X=RHS(M) IF (N.EQ.0) RETURN IS=1 DO 20 I=1,N CALL DROTG(R(IS), B(I), ALPHA, BETA) CALL DROT(M, Q(I, 1), K, Q(M, 1), K, ALPHA, BETA) U=RHS(I) RHS(I)=ALPHA*U+BETA*X X=-BETA*U+ALPHA*X IS=IS+I+1 IF (N-I.GE.1) 1 CALL DS4ROT(N-I,R(IS-1),I+1,B(I+1),-1,ALPHA,BETA) 20 CONTINUE RHS(M)=X RETURN END SUBROUTINE DD7DGB(B, D, DIG, DST, G, IPIV, KA, L, LV, P, PC, 1 NWTST, STEP, TD, TG, V, W, X0) C C *** COMPUTE DOUBLE-DOGLEG STEP, SUBJECT TO SIMPLE BOUNDS ON X *** C INTEGER LV, KA, P, PC INTEGER IPIV(P) DOUBLE PRECISION B(2,P), D(P), DIG(P), DST(P), G(P), L(1), 1 NWTST(P), STEP(P), TD(P), TG(P), V(LV), W(P), 2 X0(P) C C DIMENSION L(P*(P+1)/2) C DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM EXTERNAL DD7DOG, DD7TPR, I7SHFT, DL7ITV, DL7IVM, DL7TVM,DL7VML, 1 DQ7RSH, DR7MDC, DV2NRM,DV2AXY,DV7CPY, DV7IPR, DV7SCP, 2 DV7SHF, DV7VMP C C *** LOCAL VARIABLES *** C INTEGER I, J, K, P1, P1M1 DOUBLE PRECISION DNWTST, GHINVG, GNORM, GNORM0, NRED, PRED, RAD, 1 T, T1, T2, TI, X0I, XI DOUBLE PRECISION HALF, MEPS2, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER DGNORM, DST0, DSTNRM, GRDFAC, GTHG, GTSTEP, NREDUC, 1 NWTFAC, PREDUC, RADIUS, STPPAR C C/6 C DATA DGNORM/1/, DST0/3/, DSTNRM/2/, GRDFAC/45/, GTHG/44/, C 1 GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/, RADIUS/8/, C 2 STPPAR/5/ C/7 PARAMETER (DGNORM=1, DST0=3, DSTNRM=2, GRDFAC=45, GTHG=44, 1 GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, RADIUS=8, 2 STPPAR=5) C/ C/6 C DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0) SAVE MEPS2 C/ DATA MEPS2/0.D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (MEPS2 .LE. ZERO) MEPS2 = TWO * DR7MDC(3) GNORM0 = V(DGNORM) V(DSTNRM) = ZERO IF (KA .LT. 0) GO TO 10 DNWTST = V(DST0) NRED = V(NREDUC) 10 PRED = ZERO V(STPPAR) = ZERO RAD = V(RADIUS) IF (PC .GT. 0) GO TO 20 DNWTST = ZERO CALL DV7SCP(P, STEP, ZERO) GO TO 140 C 20 P1 = PC CALL DV7CPY(P, TD, D) CALL DV7IPR(P, IPIV, TD) CALL DV7SCP(PC, DST, ZERO) CALL DV7CPY(P, TG, G) CALL DV7IPR(P, IPIV, TG) C 30 CALL DL7IVM(P1, NWTST, L, TG) GHINVG = DD7TPR(P1, NWTST, NWTST) V(NREDUC) = HALF * GHINVG CALL DL7ITV(P1, NWTST, L, NWTST) CALL DV7VMP(P1, STEP, NWTST, TD, 1) V(DST0) = DV2NRM(PC, STEP) IF (KA .GE. 0) GO TO 40 KA = 0 DNWTST = V(DST0) NRED = V(NREDUC) 40 V(RADIUS) = RAD - V(DSTNRM) IF (V(RADIUS) .LE. ZERO) GO TO 100 CALL DV7VMP(P1, DIG, TG, TD, -1) GNORM = DV2NRM(P1, DIG) IF (GNORM .LE. ZERO) GO TO 100 V(DGNORM) = GNORM CALL DV7VMP(P1, DIG, DIG, TD, -1) CALL DL7TVM(P1, W, L, DIG) V(GTHG) = DV2NRM(P1, W) KA = KA + 1 CALL DD7DOG(DIG, LV, P1, NWTST, STEP, V) C C *** FIND T SUCH THAT X - T*STEP IS STILL FEASIBLE. C T = ONE K = 0 DO 70 I = 1, P1 J = IPIV(I) X0I = X0(J) + DST(I)/TD(I) XI = X0I + STEP(I) IF (XI .LT. B(1,J)) GO TO 50 IF (XI .LE. B(2,J)) GO TO 70 TI = (B(2,J) - X0I) / STEP(I) J = I GO TO 60 50 TI = (B(1,J) - X0I) / STEP(I) J = -I 60 IF (T .LE. TI) GO TO 70 K = J T = TI 70 CONTINUE C C *** UPDATE DST, TG, AND PRED *** C CALL DV7VMP(P1, STEP, STEP, TD, 1) CALL DV2AXY(P1, DST, T, STEP, DST) V(DSTNRM) = DV2NRM(PC, DST) T1 = T * V(GRDFAC) T2 = T * V(NWTFAC) PRED = PRED - T1*GNORM * ((T2 + ONE)*GNORM) 1 - T2 * (ONE + HALF*T2)*GHINVG 2 - HALF * (V(GTHG)*T1)**2 IF (K .EQ. 0) GO TO 100 CALL DL7VML(P1, W, L, W) T2 = ONE - T2 DO 80 I = 1, P1 80 TG(I) = T2*TG(I) - T1*W(I) C C *** PERMUTE L, ETC. IF NECESSARY *** C P1M1 = P1 - 1 J = IABS(K) IF (J .EQ. P1) GO TO 90 CALL DQ7RSH(J, P1, .FALSE., TG, L, W) CALL I7SHFT(P1, J, IPIV) CALL DV7SHF(P1, J, TG) CALL DV7SHF(P1, J, TD) CALL DV7SHF(P1, J, DST) 90 IF (K .LT. 0) IPIV(P1) = -IPIV(P1) P1 = P1M1 IF (P1 .GT. 0) GO TO 30 C C *** UNSCALE STEP, UPDATE X AND DIHDI *** C 100 CALL DV7SCP(P, STEP, ZERO) DO 110 I = 1, PC J = IABS(IPIV(I)) STEP(J) = DST(I) / TD(I) 110 CONTINUE C C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS C *** TO THEIR BOUNDS *** C IF (P1 .GE. PC) GO TO 140 CALL DV2AXY(P, TD, ONE, STEP, X0) K = P1 + 1 DO 130 I = K, PC J = IPIV(I) T = MEPS2 IF (J .GT. 0) GO TO 120 T = -T J = -J IPIV(I) = J 120 T = T * DMAX1(DABS(TD(J)), DABS(X0(J))) STEP(J) = STEP(J) + T 130 CONTINUE C 140 V(DGNORM) = GNORM0 V(NREDUC) = NRED V(PREDUC) = PRED V(RADIUS) = RAD V(DST0) = DNWTST V(GTSTEP) = DD7TPR(P, STEP, G) C 999 RETURN C *** LAST LINE OF DD7DGB FOLLOWS *** END SUBROUTINE DD7DOG(DIG, LV, N, NWTSTP, STEP, V) C C *** COMPUTE DOUBLE DOGLEG STEP *** C C *** PARAMETER DECLARATIONS *** C INTEGER LV, N DOUBLE PRECISION DIG(N), NWTSTP(N), STEP(N), V(LV) C C *** PURPOSE *** C C THIS SUBROUTINE COMPUTES A CANDIDATE STEP (FOR USE IN AN UNCON- C STRAINED MINIMIZATION CODE) BY THE DOUBLE DOGLEG ALGORITHM OF C DENNIS AND MEI (REF. 1), WHICH IS A VARIATION ON POWELL*S DOGLEG C SCHEME (REF. 2, P. 95). C C-------------------------- PARAMETER USAGE -------------------------- C C DIG (INPUT) DIAG(D)**-2 * G -- SEE ALGORITHM NOTES. C G (INPUT) THE CURRENT GRADIENT VECTOR. C LV (INPUT) LENGTH OF V. C N (INPUT) NUMBER OF COMPONENTS IN DIG, G, NWTSTP, AND STEP. C NWTSTP (INPUT) NEGATIVE NEWTON STEP -- SEE ALGORITHM NOTES. C STEP (OUTPUT) THE COMPUTED STEP. C V (I/O) VALUES ARRAY, THE FOLLOWING COMPONENTS OF WHICH ARE C USED HERE... C V(BIAS) (INPUT) BIAS FOR RELAXED NEWTON STEP, WHICH IS V(BIAS) OF C THE WAY FROM THE FULL NEWTON TO THE FULLY RELAXED NEWTON C STEP. RECOMMENDED VALUE = 0.8 . C V(DGNORM) (INPUT) 2-NORM OF DIAG(D)**-1 * G -- SEE ALGORITHM NOTES. C V(DSTNRM) (OUTPUT) 2-NORM OF DIAG(D) * STEP, WHICH IS V(RADIUS) C UNLESS V(STPPAR) = 0 -- SEE ALGORITHM NOTES. C V(DST0) (INPUT) 2-NORM OF DIAG(D) * NWTSTP -- SEE ALGORITHM NOTES. C V(GRDFAC) (OUTPUT) THE COEFFICIENT OF DIG IN THE STEP RETURNED -- C STEP(I) = V(GRDFAC)*DIG(I) + V(NWTFAC)*NWTSTP(I). C V(GTHG) (INPUT) SQUARE-ROOT OF (DIG**T) * (HESSIAN) * DIG -- SEE C ALGORITHM NOTES. C V(GTSTEP) (OUTPUT) INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE FULL NEWTON C STEP. C V(NWTFAC) (OUTPUT) THE COEFFICIENT OF NWTSTP IN THE STEP RETURNED -- C SEE V(GRDFAC) ABOVE. C V(PREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE STEP RETURNED. C V(RADIUS) (INPUT) THE TRUST REGION RADIUS. D TIMES THE STEP RETURNED C HAS 2-NORM V(RADIUS) UNLESS V(STPPAR) = 0. C V(STPPAR) (OUTPUT) CODE TELLING HOW STEP WAS COMPUTED... 0 MEANS A C FULL NEWTON STEP. BETWEEN 0 AND 1 MEANS V(STPPAR) OF THE C WAY FROM THE NEWTON TO THE RELAXED NEWTON STEP. BETWEEN C 1 AND 2 MEANS A TRUE DOUBLE DOGLEG STEP, V(STPPAR) - 1 OF C THE WAY FROM THE RELAXED NEWTON TO THE CAUCHY STEP. C GREATER THAN 2 MEANS 1 / (V(STPPAR) - 1) TIMES THE CAUCHY C STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C LET G AND H BE THE CURRENT GRADIENT AND HESSIAN APPROXIMA- C TION RESPECTIVELY AND LET D BE THE CURRENT SCALE VECTOR. THIS C ROUTINE ASSUMES DIG = DIAG(D)**-2 * G AND NWTSTP = H**-1 * G. C THE STEP COMPUTED IS THE SAME ONE WOULD GET BY REPLACING G AND H C BY DIAG(D)**-1 * G AND DIAG(D)**-1 * H * DIAG(D)**-1, C COMPUTING STEP, AND TRANSLATING STEP BACK TO THE ORIGINAL C VARIABLES, I.E., PREMULTIPLYING IT BY DIAG(D)**-1. C C *** REFERENCES *** C C 1. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI- C MIZATION ALGORITHMS WHICH USE FUNCTION AND GRADIENT C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482. C 2. POWELL, M.J.D. (1970), A HYBRID METHOD FOR NON-LINEAR EQUATIONS, C IN NUMERICAL METHODS FOR NON-LINEAR EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I DOUBLE PRECISION CFACT, CNORM, CTRNWT, GHINVG, FEMNSQ, GNORM, 1 NWTNRM, RELAX, RLAMBD, T, T1, T2 DOUBLE PRECISION HALF, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER BIAS, DGNORM, DSTNRM, DST0, GRDFAC, GTHG, GTSTEP, 1 NREDUC, NWTFAC, PREDUC, RADIUS, STPPAR C C *** DATA INITIALIZATIONS *** C C/6 C DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0) C/ C C/6 C DATA BIAS/43/, DGNORM/1/, DSTNRM/2/, DST0/3/, GRDFAC/45/, C 1 GTHG/44/, GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/, C 2 RADIUS/8/, STPPAR/5/ C/7 PARAMETER (BIAS=43, DGNORM=1, DSTNRM=2, DST0=3, GRDFAC=45, 1 GTHG=44, GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, 2 RADIUS=8, STPPAR=5) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NWTNRM = V(DST0) RLAMBD = ONE IF (NWTNRM .GT. ZERO) RLAMBD = V(RADIUS) / NWTNRM GNORM = V(DGNORM) GHINVG = TWO * V(NREDUC) V(GRDFAC) = ZERO V(NWTFAC) = ZERO IF (RLAMBD .LT. ONE) GO TO 30 C C *** THE NEWTON STEP IS INSIDE THE TRUST REGION *** C V(STPPAR) = ZERO V(DSTNRM) = NWTNRM V(GTSTEP) = -GHINVG V(PREDUC) = V(NREDUC) V(NWTFAC) = -ONE DO 20 I = 1, N 20 STEP(I) = -NWTSTP(I) GO TO 999 C 30 V(DSTNRM) = V(RADIUS) CFACT = (GNORM / V(GTHG))**2 C *** CAUCHY STEP = -CFACT * G. CNORM = GNORM * CFACT RELAX = ONE - V(BIAS) * (ONE - GNORM*CNORM/GHINVG) IF (RLAMBD .LT. RELAX) GO TO 50 C C *** STEP IS BETWEEN RELAXED NEWTON AND FULL NEWTON STEPS *** C V(STPPAR) = ONE - (RLAMBD - RELAX) / (ONE - RELAX) T = -RLAMBD V(GTSTEP) = T * GHINVG V(PREDUC) = RLAMBD * (ONE - HALF*RLAMBD) * GHINVG V(NWTFAC) = T DO 40 I = 1, N 40 STEP(I) = T * NWTSTP(I) GO TO 999 C 50 IF (CNORM .LT. V(RADIUS)) GO TO 70 C C *** THE CAUCHY STEP LIES OUTSIDE THE TRUST REGION -- C *** STEP = SCALED CAUCHY STEP *** C T = -V(RADIUS) / GNORM V(GRDFAC) = T V(STPPAR) = ONE + CNORM / V(RADIUS) V(GTSTEP) = -V(RADIUS) * GNORM V(PREDUC) = V(RADIUS)*(GNORM - HALF*V(RADIUS)*(V(GTHG)/GNORM)**2) DO 60 I = 1, N 60 STEP(I) = T * DIG(I) GO TO 999 C C *** COMPUTE DOGLEG STEP BETWEEN CAUCHY AND RELAXED NEWTON *** C *** FEMUR = RELAXED NEWTON STEP MINUS CAUCHY STEP *** C 70 CTRNWT = CFACT * RELAX * GHINVG / GNORM C *** CTRNWT = INNER PROD. OF CAUCHY AND RELAXED NEWTON STEPS, C *** SCALED BY GNORM**-1. T1 = CTRNWT - GNORM*CFACT**2 C *** T1 = INNER PROD. OF FEMUR AND CAUCHY STEP, SCALED BY C *** GNORM**-1. T2 = V(RADIUS)*(V(RADIUS)/GNORM) - GNORM*CFACT**2 T = RELAX * NWTNRM FEMNSQ = (T/GNORM)*T - CTRNWT - T1 C *** FEMNSQ = SQUARE OF 2-NORM OF FEMUR, SCALED BY GNORM**-1. T = T2 / (T1 + DSQRT(T1**2 + FEMNSQ*T2)) C *** DOGLEG STEP = CAUCHY STEP + T * FEMUR. T1 = (T - ONE) * CFACT V(GRDFAC) = T1 T2 = -T * RELAX V(NWTFAC) = T2 V(STPPAR) = TWO - T V(GTSTEP) = T1*GNORM**2 + T2*GHINVG V(PREDUC) = -T1*GNORM * ((T2 + ONE)*GNORM) 1 - T2 * (ONE + HALF*T2)*GHINVG 2 - HALF * (V(GTHG)*T1)**2 DO 80 I = 1, N 80 STEP(I) = T1*DIG(I) + T2*NWTSTP(I) C 999 RETURN C *** LAST LINE OF DD7DOG FOLLOWS *** END SUBROUTINE DD7DUP(D, HDIAG, IV, LIV, LV, N, V) C C *** UPDATE SCALE VECTOR D FOR DMNH *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION D(N), HDIAG(N), V(LV) C C *** LOCAL VARIABLES *** C INTEGER DTOLI, D0I, I DOUBLE PRECISION T, VDFAC C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTOL, DTYPE, NITER C/6 C DATA DFAC/41/, DTOL/59/, DTYPE/16/, NITER/31/ C/7 PARAMETER (DFAC=41, DTOL=59, DTYPE=16, NITER=31) C/ C C------------------------------- BODY -------------------------------- C I = IV(DTYPE) IF (I .EQ. 1) GO TO 10 IF (IV(NITER) .GT. 0) GO TO 999 C 10 DTOLI = IV(DTOL) D0I = DTOLI + N VDFAC = V(DFAC) DO 20 I = 1, N T = DMAX1(DSQRT(DABS(HDIAG(I))), VDFAC*D(I)) IF (T .LT. V(DTOLI)) T = DMAX1(V(DTOLI), V(D0I)) D(I) = T DTOLI = DTOLI + 1 D0I = D0I + 1 20 CONTINUE C 999 RETURN C *** LAST CARD OF DD7DUP FOLLOWS *** END SUBROUTINE DD7MLP(N, X, Y, Z, K) C C *** SET X = DIAG(Y)**K * Z C *** FOR X, Z = LOWER TRIANG. MATRICES STORED COMPACTLY BY ROW C *** K = 1 OR -1. C INTEGER N, K C/6 C DOUBLE PRECISION X(1), Y(N), Z(1) C/7 DOUBLE PRECISION X(*), Y(N), Z(*) C/ INTEGER I, J, L DOUBLE PRECISION ONE, T DATA ONE/1.D+0/ C L = 1 IF (K .GE. 0) GO TO 30 DO 20 I = 1, N T = ONE / Y(I) DO 10 J = 1, I X(L) = T * Z(L) L = L + 1 10 CONTINUE 20 CONTINUE GO TO 999 C 30 DO 50 I = 1, N T = Y(I) DO 40 J = 1, I X(L) = T * Z(L) L = L + 1 40 CONTINUE 50 CONTINUE 999 RETURN C *** LAST CARD OF DD7MLP FOLLOWS *** END DOUBLE PRECISION FUNCTION DD7TPR(P, X, Y) C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C INTEGER P DOUBLE PRECISION X(P), Y(P) C INTEGER I DOUBLE PRECISION ONE, SQTETA, T, ZERO DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C C *** DR7MDC(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C C/6 C DATA ONE/1.D+0/, SQTETA/0.D+0/, ZERO/0.D+0/ C/7 PARAMETER (ONE=1.D+0, ZERO=0.D+0) DATA SQTETA/0.D+0/ C/ C DD7TPR = ZERO IF (P .LE. 0) GO TO 999 IF (SQTETA .EQ. ZERO) SQTETA = DR7MDC(2) DO 20 I = 1, P T = DMAX1(DABS(X(I)), DABS(Y(I))) IF (T .GT. ONE) GO TO 10 IF (T .LT. SQTETA) GO TO 20 T = (X(I)/SQTETA)*Y(I) IF (DABS(T) .LT. SQTETA) GO TO 20 10 DD7TPR = DD7TPR + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST LINE OF DD7TPR FOLLOWS *** END SUBROUTINE DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** UPDATE SCALE VECTOR D FOR NL2IT *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N, ND, NN, N2, P INTEGER IV(LIV) DOUBLE PRECISION D(P), DR(ND,P), V(LV) C DIMENSION V(*) C C *** LOCAL VARIABLES *** C INTEGER D0, I, JCN0, JCN1, JCNI, JTOL0, JTOLI, K, SII DOUBLE PRECISION T, VDFAC C C *** CONSTANTS *** C DOUBLE PRECISION ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C *** EXTERNAL SUBROUTINE *** C EXTERNAL DV7SCP C C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTYPE, JCN, JTOL, NITER, S C/6 C DATA DFAC/41/, DTYPE/16/, JCN/66/, JTOL/59/, NITER/31/, S/62/ C/7 PARAMETER (DFAC=41, DTYPE=16, JCN=66, JTOL=59, NITER=31, S=62) C/ C C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C C------------------------------- BODY -------------------------------- C IF (IV(DTYPE) .NE. 1 .AND. IV(NITER) .GT. 0) GO TO 999 JCN1 = IV(JCN) JCN0 = IABS(JCN1) - 1 IF (JCN1 .LT. 0) GO TO 10 IV(JCN) = -JCN1 CALL DV7SCP(P, V(JCN1), ZERO) 10 DO 30 I = 1, P JCNI = JCN0 + I T = V(JCNI) DO 20 K = 1, NN 20 T = DMAX1(T, DABS(DR(K,I))) V(JCNI) = T 30 CONTINUE IF (N2 .LT. N) GO TO 999 VDFAC = V(DFAC) JTOL0 = IV(JTOL) - 1 D0 = JTOL0 + P SII = IV(S) - 1 DO 50 I = 1, P SII = SII + I JCNI = JCN0 + I T = V(JCNI) IF (V(SII) .GT. ZERO) T = DMAX1(DSQRT(V(SII)), T) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = DMAX1(V(D0), V(JTOLI)) D(I) = DMAX1(VDFAC*D(I), T) 50 CONTINUE C 999 RETURN C *** LAST CARD OF DD7UPD FOLLOWS *** END SUBROUTINE DEIGEN(NM,N,A,WR,WI,Z) DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N) C COMMON/CSTAK/D DOUBLE PRECISION D(500) C C DEIGEN FINDS THE EIGENVALUES AND EIGENVECTORS C OF A DOUBLE-PRECISION MATRIX (NOT IMAGINARY) BY C CALLING THE SEQUENCE OF SUBROUTINES C DORTHE,DORTRA, AND DHQR2, WHICH, IN TURN, ARE C THE EISPACK ROUTINES ORTHES, ORTRAN, AND HQR2, C ADJUSTED FOR DOUBLE PRECISION. C C ON INPUT - C C NM - AN INTEGER INPUT VARIABLE SET EQUAL TO C THE ROW DIMENSION OF THE TWO-DIMENSIONAL ARRAYS C A AND Z AS SPECIFIED IN THE DIMENSION STATEMENTS C FOR A AND Z IN THE CALLING PROGRAM. C C N - AN INTEGER INPUT VARIABLE SET EQUAL TO THE C ORDER OF THE MATRIX A. C C N MUST NOT BE GREATER THAN NM. C C A - THE MATRIX, A DOUBLE-PRECISION TWO-DIMENSIONAL C ARRAY WITH ROW DIMENSION NM AND COLUMN C DIMENSION AT LEAST N. C C A IS OVERWRITTEN. C C C C ON OUTPUT - C C WR - A DOUBLE-PRECISION ARRAY OF DIMENSION C AT LEAST N CONTAINING THE REAL PARTS OF THE EIGENVALUES C C WI - A DOUBLE-PRECISION ARRAY OF DIMENSION C AT LEAST N CONTAINING THE IMAGINARY PARTS OF THE EIGENVALUES. C C THE EIGENVALUES ARE UNORDERED EXCEPT THAT C COMPLEX CONJUGATE PAIRS OF EIGENVALUES C APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING C THE POSITIVE IMAGINARY PART FIRST. C C Z - A DOUBLE-PRECISION TWO-DIMENSIONAL ARRAY C WITH ROW DIMENSION NM AND COLUMN DIMENSION C AT LEAST N CONTAINING THE REAL AND IMAGINARY PARTS C OF THE EIGENVECTORS. C C IF THE J-TH EIGENVALUE IS REAL, THE J-TH C COLUMN OF Z CONTAINS ITS EIGENVECTOR. C C IF THE J-TH EIGENVALUE IS COMPLEX WITH C POSITIVE REAL PART, THE J-TH AND (J+1)-TH C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY C PARTS OF ITS EIGENVECTOR. C C THE CONJUGATE OF THIS VECTOR IS THE C EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. C THE EIGENVECTORS ARE NOT NORMALIZED. C C C ERROR STATES - C C 1 - N IS GREATER THAN NM C C K - THE K-TH EIGENVALUE COULD NOT BE COMPUTED C WITHIN 30 ITERATIONS. C C THE EIGENVALUES IN THE WR AND WRI ARRAYS C SHOULD BE CORRECT FOR INDICES C K+1, K+2,...,N, BUT NO EIGENVECTORS ARE COMPUTED. C C C C C CHECK FOR INPUT ERROR IN N C C/6S C IF (N .GT. NM) CALL SETERR( C 1 29HDEIGEN - N IS GREATER THAN NM,29,1,2) C/7S IF (N .GT. NM) CALL SETERR( 1 'DEIGEN - N IS GREATER THAN NM',29,1,2) C/ C C ALLOCATE A SCRATCH VECTOR IORT = ISTKGT(N,4) C CALL DORTHE (NM,N,1,N,A,D(IORT)) CALL DORTRA (NM,N,1,N,A,D(IORT),Z) CALL DHQR2 (NM,N,1,N,A,WR,WI,Z,IERR) C IF (IERR .NE. 0) GO TO 10 CALL ISTKRL(1) RETURN C/6S C 10 CALL SETERR( C 1 34HDEIGEN - FAILED ON THAT EIGENVALUE,34,IERR,1) C/7S 10 CALL SETERR( 1 'DEIGEN - FAILED ON THAT EIGENVALUE',34,IERR,1) C/ C CALL ISTKRL(1) RETURN END SUBROUTINE DF7DHB(B, D, G, IRT, IV, LIV, LV, P, V, X) C C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING C *** AT V(IV(FDH)) = V(-IV(H)). HONOR SIMPLE BOUNDS IN B. C C *** IF IV(COVREQ) .GE. 0 THEN DF7DHB USES GRADIENT DIFFERENCES, C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN DG7LIT. C C IRT VALUES... C 1 = COMPUTE FUNCTION VALUE, I.E., V(F). C 2 = COMPUTE G. C 3 = DONE. C C C *** PARAMETER DECLARATIONS *** C INTEGER IRT, LIV, LV, P INTEGER IV(LIV) DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P) C C *** LOCAL VARIABLES *** C LOGICAL OFFSID INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2, 1 NEWM1, PP1O2, STPI, STPM, STP0 DOUBLE PRECISION DEL, DEL0, T, XM, XM1 DOUBLE PRECISION HALF, HLIM, ONE, TWO, ZERO C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DV7CPY, DV7SCP C C DV7CPY.... COPY ONE VECTOR TO ANOTHER. C DV7SCP... COPY SCALAR TO ALL COMPONENTS OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE, 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE C C/6 C DATA HALF/0.5D+0/, HLIM/0.1D+0/, ONE/1.D+0/, TWO/2.D+0/, C 1 ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, HLIM=0.1D+0, ONE=1.D+0, TWO=2.D+0, 1 ZERO=0.D+0) C/ C C/6 C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/, C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/, C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/ C/7 PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10, 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7, 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IRT = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 HES = IABS(IV(H)) IV(H) = -HES IV(FDH) = 0 IV(KAGQT) = -1 V(FX) = V(F) C *** SUPPLY ZEROS IN CASE B(1,I) = B(2,I) FOR SOME I *** CALL DV7SCP(P*(P+1)/2, V(HES), ZERO) 10 IF (M .GT. P) GO TO 999 IF (KIND .LT. 0) GO TO 120 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P IF (M .GT. 0) GO TO 20 C *** FIRST CALL ON DF7DHB. SET GSAVE = G, TAKE FIRST STEP *** CALL DV7CPY(P, V(GSAVE1), G) IV(SWITCH) = IV(NFGCAL) GO TO 80 C 20 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 30 C C *** HANDLE OVERSIZE V(DELTA) *** C DEL0 = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M))) DEL = HALF * DEL IF (DABS(DEL/DEL0) .LE. HLIM) GO TO 140 C 30 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DEL = ONE / DEL DO 40 I = 1, P G(I) = DEL * (G(I) - V(GSAVE1)) GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 50 I = 1, MM1 IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I)) K = K + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P IF (B(1,I) .LT. B(2,I)) V(L) = G(I) L = L + I 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 340 IF (B(1,M) .GE. B(2,M)) GO TO 80 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M))) XM = X(M) IF (XM .LT. ZERO) GO TO 90 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 GO TO 280 90 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 GO TO 280 C 100 DEL = -DEL 110 V(XMSAVE) = XM X(M) = XM1 V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 120 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 HES = -IV(H) IF (M .GT. 0) GO TO 130 C *** FIRST CALL ON DF7DHB. *** IV(SAVEI) = 0 GO TO 240 C 130 IF (IV(TOOBIG) .EQ. 0) GO TO 150 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** 140 IV(FDH) = -2 GO TO 350 150 I = IV(SAVEI) IF (I .GT. 0) GO TO 190 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C PP1O2 = P * (P-1) / 2 HPM = HES + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C NEWM1 = 1 GO TO 260 160 HMI = HES + MM1O2 IF (MM1 .EQ. 0) GO TO 180 HPI = HES + PP1O2 DO 170 I = 1, MM1 T = ZERO IF (B(1,I) .LT. B(2,I)) T = V(FX) - (V(F) + V(HPI)) V(HMI) = T HMI = HMI + 1 HPI = HPI + 1 170 CONTINUE 180 V(HMI) = V(F) - TWO*V(FX) IF (OFFSID) V(HMI) = V(FX) - TWO*V(F) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 0 GO TO 200 C 190 X(I) = V(DELTA) C C *** FINISH COMPUTING H(M,I) *** C STPI = STP0 + I HMI = HES + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) 200 I = I + 1 IF (I .GT. M) GO TO 230 IF (B(1,I) .LT. B(2,I)) GO TO 210 GO TO 200 C 210 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IRT = 1 IF (I .LT. M) GO TO 999 NEWM1 = 2 GO TO 260 220 X(M) = V(XMSAVE) - DEL IF (OFFSID) X(M) = V(XMSAVE) + TWO*DEL GO TO 999 C 230 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 240 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 330 IF (B(1,M) .LT. B(2,M)) GO TO 250 GO TO 240 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C 250 V(XMSAVE) = X(M) NEWM1 = 3 260 XM = V(XMSAVE) DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(XM)) XM1 = XM + DEL OFFSID = .FALSE. IF (XM1 .LE. B(2,M)) GO TO 270 OFFSID = .TRUE. XM1 = XM - DEL IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300 GO TO 280 270 IF (XM-DEL .GE. B(1,M)) GO TO 290 OFFSID = .TRUE. IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310 C 280 IV(FDH) = -2 GO TO 350 C 290 IF (XM .GE. ZERO) GO TO 310 XM1 = XM - DEL 300 DEL = -DEL 310 GO TO (160, 220, 320), NEWM1 320 X(M) = XM1 STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES C *** FROM LAST ROW OF FDH... C 330 IF (B(1,P) .LT. B(2,P)) GO TO 340 I = HES + P*(P-1)/2 CALL DV7SCP(P, V(I), ZERO) C C *** RESTORE V(F), ETC. *** C 340 IV(FDH) = HES 350 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL DV7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST LINE OF DF7DHB FOLLOWS *** END SUBROUTINE DF7HES(D, G, IRT, IV, LIV, LV, P, V, X) C C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING C *** AT V(IV(FDH)) = V(-IV(H)). C C *** IF IV(COVREQ) .GE. 0 THEN DF7HES USES GRADIENT DIFFERENCES, C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN DG7LIT. C C IRT VALUES... C 1 = COMPUTE FUNCTION VALUE, I.E., V(F). C 2 = COMPUTE G. C 3 = DONE. C C C *** PARAMETER DECLARATIONS *** C INTEGER IRT, LIV, LV, P INTEGER IV(LIV) DOUBLE PRECISION D(P), G(P), V(LV), X(P) C C *** LOCAL VARIABLES *** C INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2, 1 PP1O2, STPI, STPM, STP0 DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, TWO, ZERO C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DV7CPY C C DV7CPY.... COPY ONE VECTOR TO ANOTHER. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE, 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE C C/6 C DATA HALF/0.5D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, C 1 ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0, 1 ZERO=0.D+0) C/ C C/6 C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/, C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/, C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/ C/7 PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10, 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7, 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IRT = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 IV(H) = -IABS(IV(H)) IV(FDH) = 0 IV(KAGQT) = -1 V(FX) = V(F) 10 IF (M .GT. P) GO TO 999 IF (KIND .LT. 0) GO TO 110 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P IF (M .GT. 0) GO TO 20 C *** FIRST CALL ON DF7HES. SET GSAVE = G, TAKE FIRST STEP *** CALL DV7CPY(P, V(GSAVE1), G) IV(SWITCH) = IV(NFGCAL) GO TO 90 C 20 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 40 C C *** HANDLE OVERSIZE V(DELTA) *** C IF (DEL*X(M) .GT. ZERO) GO TO 30 C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT *** IV(FDH) = -2 GO TO 220 C C *** TRY SHRINKING V(DELTA) *** 30 DEL = NEGPT5 * DEL GO TO 100 C 40 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DO 50 I = 1, P G(I) = (G(I) - V(GSAVE1)) / DEL GSAVE1 = GSAVE1 + 1 50 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 70 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 60 I = 1, MM1 V(K) = HALF * (V(K) + G(I)) K = K + 1 60 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 70 L = L + 1 DO 80 I = M, P V(L) = G(I) L = L + I 80 CONTINUE C 90 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 210 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 100 X(M) = X(M) + DEL V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 110 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 120 C *** FIRST CALL ON DF7HES. *** IV(SAVEI) = 0 GO TO 200 C 120 I = IV(SAVEI) HES = -IV(H) IF (I .GT. 0) GO TO 180 IF (IV(TOOBIG) .EQ. 0) GO TO 140 C C *** HANDLE OVERSIZE STEP *** C STPM = STP0 + M DEL = V(STPM) IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 130 C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT *** IV(FDH) = -2 GO TO 220 C C *** TRY SHRINKING THE STEP *** 130 DEL = NEGPT5 * DEL X(M) = X(XMSAVE) + DEL V(STPM) = DEL IRT = 1 GO TO 999 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C 140 PP1O2 = P * (P-1) / 2 HPM = HES + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C HMI = HES + MM1O2 IF (MM1 .EQ. 0) GO TO 160 HPI = HES + PP1O2 DO 150 I = 1, MM1 V(HMI) = V(FX) - (V(F) + V(HPI)) HMI = HMI + 1 HPI = HPI + 1 150 CONTINUE 160 V(HMI) = V(F) - TWO*V(FX) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 1 C 170 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI) IRT = 1 GO TO 999 C 180 X(I) = V(DELTA) IF (IV(TOOBIG) .EQ. 0) GO TO 190 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** IV(FDH) = -2 GO TO 220 C C *** FINISH COMPUTING H(M,I) *** C 190 STPI = STP0 + I HMI = HES + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) I = I + 1 IF (I .LE. M) GO TO 170 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 200 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 210 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** RESTORE V(F), ETC. *** C 210 IV(FDH) = HES 220 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL DV7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST CARD OF DF7HES FOLLOWS *** END SUBROUTINE DG7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X. C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 80. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C DG7ITB IS SIMILAR TO DG7LIT, EXCEPT FOR THE EXTRA PARAMETER B C -- DG7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C DG7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS), AND DG7ITB BUILDS AN APPROXIMATION, S, TO THE C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE, C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S. C DG7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO USE S WHEN CHOOSING C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL). C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S, DG7ITB ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7ITB WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO DN2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT DN2GB USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH DN2GB (AND NL2SOL), IV(1) C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE C EXPLAINED BELOW, AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM C DN2GB (AND DN2FB), ARE NOT REFERENCED BY DG7ITB OR THE C SUBROUTINES IT CALLS. C C WHEN DG7ITB IS FIRST CALLED, I.E., WHEN DG7ITB IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES, DG7ITB RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7ITB WILL MAKE C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL DG7ITB AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE DG7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME DG7ITB RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL DG7ITB AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(NFGCAL) TO 0, IN WHICH CASE DG7ITB WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL HAVQTR, HAVRM INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1, 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2, 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2, 3 TG1, W1, WLM1, X01 DOUBLE PRECISION E, GI, STTSST, T, T1, XI C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM EXTERNAL DA7SST, DD7TPR, DF7DHB, DG7QSB,I7COPY, I7PNVR, I7SHFT, 1 DITSUM, DL7MSB, DL7SQR, DL7TVM,DL7VML,DPARCK, DQ7RSH, 2 DRLDST, DS7DMP, DS7IPR, DS7LUP, DS7LVM, STOPX, DV2NRM, 3 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP C C DA7SST.... ASSESSES CANDIDATE STEP. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DF7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX). C DG7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER. C I7PNVR... INVERTS PERMUTATION ARRAY. C I7SHFT... SHIFTS AN INTEGER VECTOR. C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DL7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C DQ7RSH... SHIFTS A QR FACTORIZATION. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C DS7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX. C DS7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX. C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C DS7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7IPR... APPLIES A PERMUTATION TO A VECTOR. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT, 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV, 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0, 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS, 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP, 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5, 8 VNEED, VSAVE, W, WSCALE, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.) C C/6 C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/, C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, IVNEED/3/, C 2 KAGQT/33/, KALM/34/, LMAT/42/, MODE/35/, MODEL/5/, C 3 MXFCAL/17/, MXITER/18/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, C 4 NFGCAL/7/, NFCOV/52/, NGCOV/53/, NGCALL/30/, NITER/31/, C 5 P0/48/, PC/41/, PERM/58/, QTR/77/, RADINC/8/, RDREQ/57/, C 6 REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/, STGLIM/11/, C 7 SUSED/64/, SWITCH/12/, TOOBIG/2/, VNEED/4/, VSAVE/60/, W/65/, C 8 XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56, 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, IVNEED=3, 2 KAGQT=33, KALM=34, LMAT=42, MODE=35, MODEL=5, 3 MXFCAL=17, MXITER=18, NEXTIV=46, NEXTV=47, NFCALL=6, 4 NFGCAL=7, NFCOV=52, NGCOV=53, NGCALL=30, NITER=31, 5 P0=48, PC=41, PERM=58, QTR=77, RADINC=8, RDREQ=57, 6 REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, STGLIM=11, 7 SUSED=64, SWITCH=12, TOOBIG=2, VNEED=4, VSAVE=60, W=65, 8 XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/, C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/, C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RELDX/17/, SIZE/55/, STPPAR/5/, TUNER4/29/, C 4 TUNER5/30/, WSCALE/56/ C/7 PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45, 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36, 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RELDX=17, SIZE=55, STPPAR=5, TUNER4=29, 4 TUNER5=30, WSCALE=56) C/ C C C/6 C DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, C 1 ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, 1 ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 C IF (I .LT. 12) GO TO 10 IF (I .GT. 13) GO TO 10 IV(VNEED) = IV(VNEED) + P*(3*P + 25)/2 + 7 IV(IVNEED) = IV(IVNEED) + 4*P 10 CALL DPARCK(1, D, IV, LIV, LV, P, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I C C *** STORAGE ALLOCATION *** C 20 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + 2*P IV(DIG) = IV(STEP) + 3*P IV(W) = IV(DIG) + 2*P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IV(IPIVOT) = IV(PERM) + 3*P IV(NEXTIV) = IV(IPIVOT) + P IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(PC) = P V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(IPIVOT) DO 40 I = 1, P IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 680 40 CONTINUE C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IV(1) = 1 IF (IV(S) .LT. 0) GO TO 710 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO) GO TO 710 C C *** NEW FUNCTION VALUE *** C 50 IF (IV(MODE) .EQ. 0) GO TO 360 IF (IV(MODE) .GT. 0) GO TO 590 C IF (IV(TOOBIG) .EQ. 0) GO TO 690 IV(1) = 63 GO TO 999 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 999 C C *** NEW GRADIENT *** C 70 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 590 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670 C C *** CHOOSE INITIAL PERMUTATION *** C IPI = IV(IPIVOT) IPN = IPI + P - 1 IPIV2 = IV(PERM) - 1 K = IV(PC) P1 = P PP1 = P + 1 RMAT1 = IV(RMAT) HAVRM = RMAT1 .GT. 0 QTR1 = IV(QTR) HAVQTR = QTR1 .GT. 0 C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) *** W1 = IV(W) IF (.NOT. HAVQTR) QTR1 = W1 + P C DO 100 I = 1, P I1 = IV(IPN) IPN = IPN - 1 IF (B(1,I1) .GE. B(2,I1)) GO TO 80 XI = X(I1) GI = G(I1) IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80 IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80 C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED *** J = IPIV2 + I1 IF (IV(J) .GT. K) IV(CNVCOD) = 0 GO TO 100 80 IF (I1 .GE. P1) GO TO 90 I1 = PP1 - I CALL I7SHFT(P1, I1, IV(IPI)) IF (HAVRM) 1 CALL DQ7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1)) 90 P1 = P1 - 1 100 CONTINUE IV(PC) = P1 C C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) *** C V(DGNORM) = ZERO IF (P1 .LE. 0) GO TO 110 DIG1 = IV(DIG) CALL DV7VMP(P, V(DIG1), G, D, -1) CALL DV7IPR(P, IV(IPI), V(DIG1)) V(DGNORM) = DV2NRM(P1, V(DIG1)) 110 IF (IV(CNVCOD) .NE. 0) GO TO 580 IF (IV(MODE) .EQ. 0) GO TO 510 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 170 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 600 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 120 H1 = IV(FDH) IF (H1 .LE. 0) GO TO 660 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 130 CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 140 130 RMAT1 = IV(RMAT) LMAT1 = IV(LMAT) CALL DL7SQR(P, V(LMAT1), V(RMAT1)) IPI = IV(IPIVOT) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPI)) CALL DS7IPR(P, IV(IPIV1), V(LMAT1)) CALL DV2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1)) C C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS *** C 140 DO 160 I = 1, P IF (B(1,I) .LT. B(2,I)) GO TO 160 K = S1 + I*(I-1)/2 CALL DV7SCP(I, V(K), ZERO) IF (I .GE. P) GO TO 170 K = K + 2*I - 1 I1 = I + 1 DO 150 J = I1, P V(K) = ZERO K = K + J 150 CONTINUE 160 CONTINUE C 170 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 180 CALL DITSUM(D, G, IV, LIV, LV, P, V, X) 190 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 200 IV(1) = 10 GO TO 999 200 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 220 STEP1 = IV(STEP) DO 210 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 210 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * DV2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 220 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL DV7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 230 IF (.NOT. STOPX(DUMMY)) GO TO 250 IV(1) = 11 GO TO 260 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 240 IF (V(F) .GE. V(F0)) GO TO 250 V(RADFAC) = ONE K = IV(NITER) GO TO 200 C 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270 IV(1) = 9 260 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 500 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 270 STEP1 = IV(STEP) TG1 = IV(DIG) TD1 = TG1 + P X01 = IV(X0) W1 = IV(W) H1 = IV(H) P1 = IV(PC) IPI = IV(PERM) IPIV1 = IPI + P IPIV2 = IPIV1 + P IPIV0 = IV(IPIVOT) IF (IV(MODEL) .EQ. 2) GO TO 280 C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 280 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 280 LMAT1 = IV(LMAT) WLM1 = W1 + P CALL DL7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1), 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0), 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1), 3 V(TG1), V, V(W1), V(WLM1), X, V(X01)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 330 C 280 IF (H1 .GT. 0) GO TO 320 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C P1LEN = P1*(P1+1)/2 H1 = -H1 IV(H) = H1 IV(FDH) = 0 IF (P1 .LE. 0) GO TO 320 C *** MAKE TEMPORARY PERMUTATION ARRAY *** CALL I7COPY(P, IV(IPI), IV(IPIV0)) J = IV(HC) IF (J .GT. 0) GO TO 290 J = H1 RMAT1 = IV(RMAT) CALL DL7SQR(P1, V(H1), V(RMAT1)) GO TO 300 290 CALL DV7CPY(P*(P+1)/2, V(H1), V(J)) CALL DS7IPR(P, IV(IPI), V(H1)) 300 IF (IV(MODEL) .EQ. 1) GO TO 310 LMAT1 = IV(LMAT) S1 = IV(S) CALL DV7CPY(P*(P+1)/2, V(LMAT1), V(S1)) CALL DS7IPR(P, IV(IPI), V(LMAT1)) CALL DV2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1)) 310 CALL DV7CPY(P, V(TD1), D) CALL DV7IPR(P, IV(IPI), V(TD1)) CALL DS7DMP(P1, V(H1), V(H1), V(TD1), -1) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 320 LMAT1 = IV(LMAT) CALL DG7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2), 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1), 2 V(TD1), V(TG1), V, V(W1), X, V(X01)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 330 IF (IV(IRC) .NE. 6) GO TO 340 IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 2 GO TO 370 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 340 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 360 IF (IV(IRC) .NE. 5) GO TO 350 IF (V(RADFAC) .LE. ONE) GO TO 350 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350 STEP1 = IV(STEP) X01 = IV(X0) CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X) IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 0 GO TO 370 C C *** COMPUTE F(X0 + STEP) *** C 350 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 360 RSTRST = 3 370 X01 = IV(X0) V(RELDX) = DRLDST(P, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = X01 + P I = IV(RESTOR) + 1 GO TO (410, 380, 390, 400), I 380 CALL DV7CPY(P, X, V(X01)) GO TO 410 390 CALL DV7CPY(P, V(LSTGST), V(STEP1)) GO TO 410 400 CALL DV7CPY(P, V(STEP1), V(LSTGST)) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = DRLDST(P, D, X, V(X01)) IV(RESTOR) = RSTRST C C *** IF NECESSARY, SWITCH MODELS *** C 410 IF (IV(SWITCH) .EQ. 0) GO TO 420 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL DV7CPY(NVSAVE, V, V(L)) 420 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL DS7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * DD7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 430 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 470 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL DV7CPY(NVSAVE, V(L), V) GO TO 230 C 430 IF (-3 .LT. L) GO TO 470 C C *** RECOMPUTE STEP WITH DIFFERENT RADIUS *** C 440 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 230 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST C 450 V(RADIUS) = V(LMAXS) GO TO 270 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 460 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 580 IF (IV(XIRC) .EQ. 14) GO TO 580 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 470 IV(COVMAT) = 0 IV(REGD) = 0 C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C IF (IV(IRC) .NE. 3) GO TO 500 STEP1 = IV(STEP) TEMP1 = STEP1 + P TEMP2 = IV(X0) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL DS7LVM(P, V(TEMP1), V(HC1), V(STEP1)) GO TO 490 480 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL DV7CPY(P, V(TEMP1), V(STEP1)) CALL DV7IPR(P, IV(IPIV0), V(TEMP1)) CALL DL7TVM(P, V(TEMP1), V(RMAT1), V(TEMP1)) CALL DL7VML(P, V(TEMP1), V(RMAT1), V(TEMP1)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL DV7IPR(P, IV(IPIV1), V(TEMP1)) C 490 IF (STPMOD .EQ. 1) GO TO 500 S1 = IV(S) CALL DS7LVM(PS, V(TEMP2), V(S1), V(STEP1)) CALL DV2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1)) C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 500 IV(NGCALL) = IV(NGCALL) + 1 G01 = IV(W) CALL DV7CPY(P, V(G01), G) GO TO 690 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 510 G01 = IV(W) CALL DV2AXY(P, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = STEP1 + P TEMP2 = IV(X0) IF (IV(IRC) .NE. 3) GO TO 540 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 520 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 520 CONTINUE C C *** DO GRADIENT TESTS *** C IF (DV2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 530 IF (DD7TPR(P, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 540 530 V(RADFAC) = V(INCFAC) C C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S *** C 540 CALL DV2AXY(PS, Y, NEGONE, Y, G) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL DS7LVM(PS, V(TEMP1), V(S1), V(STEP1)) C T1 = DABS(DD7TPR(PS, V(STEP1), V(TEMP1))) T = DABS(DD7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 550 CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 560 C 550 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL DV7CPY(P, V(G01), V(STEP1)) I = G01 + PS IF (PS .LT. P) CALL DV7SCP(P-PS, V(I), ZERO) CALL DV7IPR(P, IV(IPIV0), V(G01)) CALL DL7TVM(P, V(G01), V(RMAT1), V(G01)) CALL DL7VML(P, V(G01), V(RMAT1), V(G01)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL DV7IPR(P, IV(IPIV1), V(G01)) C 560 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 180 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 570 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 580 IF (IV(RDREQ) .EQ. 0) GO TO 660 IF (IV(FDH) .NE. 0) GO TO 660 IF (IV(CNVCOD) .GE. 7) GO TO 660 IF (IV(REGD) .GT. 0) GO TO 660 IF (IV(COVMAT) .GT. 0) GO TO 660 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 600 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 590 IV(RESTOR) = 0 600 CALL DF7DHB(B, D, G, I, IV, LIV, LV, P, V, X) GO TO (610, 620, 630), I 610 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C 620 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) GO TO 690 C 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120 GO TO 660 C 640 H1 = IABS(IV(H)) IV(FDH) = H1 IV(H) = -H1 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 650 CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1)) GO TO 660 650 RMAT1 = IV(RMAT) CALL DL7SQR(P, V(H1), V(RMAT1)) C 660 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 670 IV(1) = 1400 GO TO 999 C C *** INCONSISTENT B *** C 680 IV(1) = 82 GO TO 999 C C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G *** C 690 IV(1) = 2 J = IV(IPIVOT) IPI = IV(PERM) CALL I7PNVR(P, IV(IPI), IV(J)) DO 700 I = 1, P IV(J) = I J = J + 1 700 CONTINUE C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 710 DO 720 I = 1, P IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 720 CONTINUE IV(TOOBIG) = 0 C 999 RETURN C C *** LAST LINE OF DG7ITB FOLLOWS *** END SUBROUTINE DG7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) DOUBLE PRECISION D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 82. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C DG7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND DG7LIT BUILDS AN C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD C VECTOR USED IN UPDATING S. DG7LIT DECIDES DYNAMICALLY WHETHER OR C NOT TO USE S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR C HC + S (AUGMENTED MODEL). C C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S,DG7LIT ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7LIT WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY DG7LIT OR THE SUBROUTINES IT CALLS. C C WHEN DG7LIT IS FIRST CALLED, I.E., WHEN DG7LIT IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES,DG7LIT RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7LIT WILL MAKE A C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL DG7LIT AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE DG7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME DG7LIT RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL DG7LIT AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(TOOBIG) TO 1, IN WHICH CASE DG7LIT WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1, 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, 2 TEMP1, TEMP2, W1, X01 DOUBLE PRECISION E, STTSST, T, T1 C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DRLDST, DR7MDC, DV2NRM EXTERNAL DA7SST, DD7TPR,DF7HES,DG7QTS,DITSUM, DL7MST,DL7SRT, 1 DL7SQR, DL7SVX, DL7SVN, DL7TVM,DL7VML,DPARCK, DRLDST, 2 DR7MDC, DS7LUP, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP, 3 DV2NRM C C DA7SST.... ASSESSES CANDIDATE STEP. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DF7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE). C DG7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DL7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F, 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS, 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL, 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV, 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR, 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED, 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE, 8 XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/, C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, KAGQT/33/, C 2 KALM/34/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, C 3 MXITER/18/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NFCOV/52/, C 4 NGCOV/53/, NGCALL/30/, NITER/31/, QTR/77/, RADINC/8/, C 5 RDREQ/57/, REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/, C 6 STGLIM/11/, STLSTG/41/, SUSED/64/, SWITCH/12/, TOOBIG/2/, C 7 VNEED/4/, VSAVE/60/, W/65/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56, 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, KAGQT=33, 2 KALM=34, LMAT=42, MODE=35, MODEL=5, MXFCAL=17, 3 MXITER=18, NEXTV=47, NFCALL=6, NFGCAL=7, NFCOV=52, 4 NGCOV=53, NGCALL=30, NITER=31, QTR=77, RADINC=8, 5 RDREQ=57, REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, 6 STGLIM=11, STLSTG=41, SUSED=64, SWITCH=12, TOOBIG=2, 7 VNEED=4, VSAVE=60, W=65, XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/, C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/, C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RCOND/53/, RELDX/17/, SIZE/55/, STPPAR/5/, C 4 TUNER4/29/, TUNER5/30/, WSCALE/56/ C/7 PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45, 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36, 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RCOND=53, RELDX=17, SIZE=55, STPPAR=5, 4 TUNER4=29, TUNER5=30, WSCALE=56) C/ C C C/6 C DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, C 1 ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, 1 ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 40 IF (I .EQ. 2) GO TO 50 C IF (I .EQ. 12 .OR. I .EQ. 13) 1 IV(VNEED) = IV(VNEED) + P*(3*P + 19)/2 + 7 CALL DPARCK(1, D, IV, LIV, LV, P, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I C C *** STORAGE ALLOCATION *** C 10 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(W) = IV(DIG) + P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(RESTOR) = 0 IV(FDH) = 0 V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(S) .LT. 0) GO TO 999 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO) IV(1) = 1 J = IV(IPIVOT) IF (J .LE. 0) GO TO 999 DO 30 I = 1, P IV(J) = I J = J + 1 30 CONTINUE GO TO 999 C C *** NEW FUNCTION VALUE *** C 40 IF (IV(MODE) .EQ. 0) GO TO 290 IF (IV(MODE) .GT. 0) GO TO 520 C IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 999 C C *** NEW GRADIENT *** C 50 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 520 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 65 GO TO 999 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610 C C *** COMPUTE D**-1 * GRADIENT *** C DIG1 = IV(DIG) K = DIG1 DO 70 I = 1, P V(K) = G(I) / D(I) K = K + 1 70 CONTINUE V(DGNORM) = DV2NRM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 510 IF (IV(MODE) .EQ. 0) GO TO 440 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 100 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 530 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 80 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 90 CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 100 90 RMAT1 = IV(RMAT) CALL DL7SQR(PS, V(S1), V(RMAT1)) CALL DV2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1)) 100 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 110 CALL DITSUM(D, G, IV, LIV, LV, P, V, X) 120 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 130 IV(1) = 10 GO TO 999 130 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 150 STEP1 = IV(STEP) DO 140 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 140 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * DV2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 150 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL DV7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 160 IF (.NOT. STOPX(DUMMY)) GO TO 180 IV(1) = 11 GO TO 190 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 170 IF (V(F) .GE. V(F0)) GO TO 180 V(RADFAC) = ONE K = IV(NITER) GO TO 130 C 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200 IV(1) = 9 190 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 430 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 200 STEP1 = IV(STEP) W1 = IV(W) H1 = IV(H) T1 = ONE IF (IV(MODEL) .EQ. 2) GO TO 210 T1 = ZERO C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 210 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 210 IPIV1 = IV(IPIVOT) CALL DL7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1), 1 V(RMAT1), V(STEP1), V, V(W1)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 260 C 210 IF (H1 .GT. 0) GO TO 250 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C H1 = -H1 IV(H) = H1 IV(FDH) = 0 J = IV(HC) IF (J .GT. 0) GO TO 220 J = H1 RMAT1 = IV(RMAT) CALL DL7SQR(P, V(H1), V(RMAT1)) 220 S1 = IV(S) DO 240 I = 1, P T = ONE / D(I) DO 230 K = 1, I V(H1) = T * (V(J) + T1*V(S1)) / D(K) J = J + 1 H1 = H1 + 1 S1 = S1 + 1 230 CONTINUE 240 CONTINUE H1 = IV(H) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 250 DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL DG7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), 1 V, V(W1)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 260 IF (IV(IRC) .NE. 6) GO TO 270 IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 2 GO TO 300 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 270 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 290 IF (IV(IRC) .NE. 5) GO TO 280 IF (V(RADFAC) .LE. ONE) GO TO 280 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280 STEP1 = IV(STEP) X01 = IV(X0) CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X) IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 0 GO TO 300 C C *** COMPUTE F(X0 + STEP) *** C 280 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 290 RSTRST = 3 300 X01 = IV(X0) V(RELDX) = DRLDST(P, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (340, 310, 320, 330), I 310 CALL DV7CPY(P, X, V(X01)) GO TO 340 320 CALL DV7CPY(P, V(LSTGST), V(STEP1)) GO TO 340 330 CALL DV7CPY(P, V(STEP1), V(LSTGST)) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = DRLDST(P, D, X, V(X01)) IV(RESTOR) = RSTRST C C *** IF NECESSARY, SWITCH MODELS *** C 340 IF (IV(SWITCH) .EQ. 0) GO TO 350 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL DV7CPY(NVSAVE, V, V(L)) 350 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL DS7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * DD7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 360 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 400 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL DV7CPY(NVSAVE, V(L), V) GO TO 160 C 360 IF (-3 .LT. L) GO TO 400 C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 370 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 160 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST C 380 V(RADIUS) = V(LMAXS) GO TO 200 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 390 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 510 IF (IV(XIRC) .EQ. 14) GO TO 510 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 400 IV(COVMAT) = 0 IV(REGD) = 0 C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C IF (IV(IRC) .NE. 3) GO TO 430 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(W) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 410 CALL DS7LVM(P, V(TEMP1), V(HC1), V(STEP1)) GO TO 420 410 RMAT1 = IV(RMAT) CALL DL7TVM(P, V(TEMP1), V(RMAT1), V(STEP1)) CALL DL7VML(P, V(TEMP1), V(RMAT1), V(TEMP1)) C 420 IF (STPMOD .EQ. 1) GO TO 430 S1 = IV(S) CALL DS7LVM(PS, V(TEMP2), V(S1), V(STEP1)) CALL DV2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1)) C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 430 IV(NGCALL) = IV(NGCALL) + 1 G01 = IV(W) CALL DV7CPY(P, V(G01), G) IV(1) = 2 IV(TOOBIG) = 0 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 440 G01 = IV(W) CALL DV2AXY(P, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(W) IF (IV(IRC) .NE. 3) GO TO 470 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 450 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 450 CONTINUE C C *** DO GRADIENT TESTS *** C IF (DV2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 460 IF (DD7TPR(P, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 470 460 V(RADFAC) = V(INCFAC) C C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S *** C 470 CALL DV2AXY(PS, Y, NEGONE, Y, G) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL DS7LVM(PS, V(TEMP1), V(S1), V(STEP1)) C T1 = DABS(DD7TPR(PS, V(STEP1), V(TEMP1))) T = DABS(DD7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 490 C 480 RMAT1 = IV(RMAT) CALL DL7TVM(PS, V(G01), V(RMAT1), V(STEP1)) CALL DL7VML(PS, V(G01), V(RMAT1), V(G01)) C 490 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 110 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 500 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 510 IF (IV(RDREQ) .EQ. 0) GO TO 600 IF (IV(FDH) .NE. 0) GO TO 600 IF (IV(CNVCOD) .GE. 7) GO TO 600 IF (IV(REGD) .GT. 0) GO TO 600 IF (IV(COVMAT) .GT. 0) GO TO 600 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 530 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 520 IV(RESTOR) = 0 530 CALL DF7HES(D, G, I, IV, LIV, LV, P, V, X) GO TO (540, 550, 580), I 540 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C 550 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) IV(1) = 2 GO TO 999 C 560 H1 = IABS(IV(H)) IV(H) = -H1 PP1O2 = P * (P + 1) / 2 RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 570 LMAT1 = IV(LMAT) CALL DV7CPY(PP1O2, V(LMAT1), V(RMAT1)) V(RCOND) = ZERO GO TO 590 570 HC1 = IV(HC) IV(FDH) = H1 CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1)) C C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN C *** FOR USE IN CALLER*S COVARIANCE CALCULATION... C 580 LMAT1 = IV(LMAT) H1 = IV(FDH) IF (H1 .LE. 0) GO TO 600 IF (IV(CNVCOD) .EQ. 70) GO TO 80 CALL DL7SRT(1, P, V(LMAT1), V(H1), I) IV(FDH) = -1 V(RCOND) = ZERO IF (I .NE. 0) GO TO 600 C 590 IV(FDH) = -1 STEP1 = IV(STEP) T = DL7SVN(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .LE. ZERO) GO TO 600 T = T / DL7SVX(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .GT. DR7MDC(4)) IV(FDH) = H1 V(RCOND) = T C 600 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 610 IV(1) = 1400 C 999 RETURN C C *** LAST LINE OF DG7LIT FOLLOWS *** END SUBROUTINE DG7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV, 1 P, P0, PC, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) DOUBLE PRECISION B(2,P), D(P), DIHDI(1), G(P), L(1), 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2) C DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR,DG7QTS, DS7BQN, DS7IPR,DV7CPY, DV7IPR, 1 DV7SCP, DV7VMP C C *** LOCAL VARIABLES *** C INTEGER K, KB, KINIT, NS, P1, P10 DOUBLE PRECISION DS0, NRED, PRED, RAD DOUBLE PRECISION ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C C/6 C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/, C 1 RADIUS/8/ C/7 PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) C/ DATA ZERO/0.D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C P1 = PC IF (KA .LT. 0) GO TO 10 NRED = V(NREDUC) DS0 = V(DST0) GO TO 20 10 P0 = 0 KA = -1 C 20 KINIT = -1 IF (P0 .EQ. P1) KINIT = KA CALL DV7CPY(P, X, X0) PRED = ZERO RAD = V(RADIUS) KB = -1 V(DSTNRM) = ZERO IF (P1 .GT. 0) GO TO 30 NRED = ZERO DS0 = ZERO CALL DV7SCP(P, STEP, ZERO) GO TO 60 C 30 CALL DV7CPY(P, TD, D) CALL DV7IPR(P, IPIV, TD) CALL DV7VMP(P, TG, G, D, -1) CALL DV7IPR(P, IPIV, TG) 40 K = KINIT KINIT = -1 V(RADIUS) = RAD - V(DSTNRM) CALL DG7QTS(TD, TG, DIHDI, K, L, P1, STEP, V, W) P0 = P1 IF (KA .GE. 0) GO TO 50 NRED = V(NREDUC) DS0 = V(DST0) C 50 KA = K V(RADIUS) = RAD P10 = P1 CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, L, LV, 1 NS, P, P1, STEP, TD, TG, V, W, X, X0) IF (NS .GT. 0) CALL DS7IPR(P10, IPIV1, DIHDI) PRED = PRED + V(PREDUC) IF (NS .NE. 0) P0 = 0 IF (KB .LE. 0) GO TO 40 C 60 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = DD7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF DG7QSB FOLLOWS *** END SUBROUTINE DG7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W) C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN *** C C *** PARAMETER DECLARATIONS *** C INTEGER KA, P DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C (DG7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT C CALL THIS ROUTINE. C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C DL7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C DL7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C DL7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C DR7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS. C DV2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB. C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL RESTRT INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK, 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ, 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI C C *** CONSTANTS *** DOUBLE PRECISION BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, 1 ONE, P001, SIX, THREE, TWO, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DL7SVN, DR7MDC, DV2NRM EXTERNAL DD7TPR, DL7ITV, DL7IVM,DL7SRT, DL7SVN, DR7MDC, DV2NRM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC, 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0 C/6 C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/, C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/, C 2 RAD0/9/, STPPAR/5/ C/7 PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4, 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8, 2 RAD0=9, STPPAR=5) C/ C C/6 C DATA EPSFAC/50.0D+0/, FOUR/4.0D+0/, HALF/0.5D+0/, C 1 KAPPA/2.0D+0/, NEGONE/-1.0D+0/, ONE/1.0D+0/, P001/1.0D-3/, C 2 SIX/6.0D+0/, THREE/3.0D+0/, TWO/2.0D+0/, ZERO/0.0D+0/ C/7 PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0, 1 KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3, 2 SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0) SAVE DGXFAC C/ DATA BIG/0.D+0/, DGXFAC/0.D+0/ C C *** BODY *** C IF (BIG .LE. ZERO) BIG = DR7MDC(6) C C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX). DGGDMX = P + 1 C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX) C *** AND W(EMIN) RESPECTIVELY. EMAX = DGGDMX + 1 EMIN = EMAX + 1 C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST, C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF. C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN) C *** RESPECTIVELY. LK0 = EMIN + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P). DIAG0 = DSTSAV DIAG = DIAG0 + 1 C *** STORE -D*STEP IN W(Q),...,W(Q0+P). Q0 = DIAG0 + P Q = Q0 + 1 C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X *** X = Q + P RAD = V(RADIUS) RADSQ = RAD**2 C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF C *** D*STEP. PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD PSIFAC = BIG T1 = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) * 1 (KAPPA + ONE) + KAPPA + TWO) * RAD) IF (T1 .LT. BIG*DMIN1(RAD,ONE)) PSIFAC = T1 / RAD C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO EPS = V(EPSLON) IRC = 0 RESTRT = .FALSE. KALIM = KA + 50 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA .GE. 0) GO TO 290 C C *** FRESH START *** C K = 0 UK = NEGONE KA = 0 KALIM = 50 V(DGNORM) = DV2NRM(P, DIG) V(NREDUC) = ZERO V(DST0) = ZERO KAMIN = 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 C C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) *** C J = 0 DO 10 I = 1, P J = J + I K1 = DIAG0 + I W(K1) = DIHDI(J) 10 CONTINUE C C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI *** C T1 = ZERO J = P * (P + 1) / 2 DO 20 I = 1, J T = DABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 20 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 30 CALL DL7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 50 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 40 I = 1, IRC 40 W(I) = ZERO W(IRC) = ONE CALL DL7ITV(IRC, W, L, W) T1 = DV2NRM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 50 LK = ZERO T = DL7SVN(P, L, W(Q), W(Q)) IF (T .GE. ONE) GO TO 60 IF (V(DGNORM) .GE. T*T*BIG) GO TO 70 60 CALL DL7IVM(P, W(Q), L, DIG) GTSTA = DD7TPR(P, W(Q), W(Q)) V(NREDUC) = HALF * GTSTA CALL DL7ITV(P, W(Q), L, W(Q)) DST = DV2NRM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 260 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = DABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = DABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + DSQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = DABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + DSQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = DMAX1(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = DMIN1(UK, DMAX1(ALPHAK, LK)) C IF (IRC .NE. 0) GO TO 210 C C *** COMPUTE L0 FOR POSITIVE DEFINITE H *** C CALL DL7IVM(P, W, L, W(Q)) T = DV2NRM(P, W) W(PHIPIN) = RAD / T / T LK = DMAX1(LK, PHI*W(PHIPIN)) C C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) *** C 210 KA = KA + 1 IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK IF (ALPHAK .LE. ZERO) ALPHAK = UK K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL DL7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 240 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL DL7ITV(IRC, W, L, W) T1 = DV2NRM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK IF (UK .LT. LK) UK = LK IF (ALPHAK .LT. LK) GO TO 210 C C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK... C T = P001 * ALPHAK IF (T .LE. ZERO) T = P001 LK = ALPHAK + T IF (UK .LE. LK) UK = LK + T GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 240 CALL DL7IVM(P, W(Q), L, DIG) GTSTA = DD7TPR(P, W(Q), W(Q)) CALL DL7ITV(P, W(Q), L, W(Q)) DST = DV2NRM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270 IF (PHI .EQ. OLDPHI) GO TO 270 OLDPHI = PHI IF (PHI .LT. ZERO) GO TO 330 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 250 IF (KA .GE. KALIM) GO TO 270 C *** THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK) C *** KAMIN = 0 ONLY IFF THE GRADIENT VANISHES *** IF (KAMIN .EQ. 0) GO TO 210 CALL DL7IVM(P, W, L, W(Q)) C *** THE FOLLOWING, COMMENTED CALCULATION OF ALPHAK IS SOMETIMES C *** SAFER BUT WORSE IN PERFORMANCE... C T1 = DST / DV2NRM(P, W) C ALPHAK = ALPHAK + T1 * (PHI/RAD) * T1 T1 = DV2NRM(P, W) ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD) LK = DMAX1(LK, ALPHAK) ALPHAK = LK GO TO 210 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 260 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 270 DO 280 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 280 CONTINUE V(GTSTEP) = -GTSTA V(PREDUC) = HALF * (DABS(ALPHAK)*DST*DST + GTSTA) GO TO 410 C C C *** RESTART WITH NEW RADIUS *** C 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 300 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 300 CONTINUE UK = NEGONE GO TO 30 C 310 KAMIN = KA + 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 IF (KA .EQ. 0) GO TO 50 C DST = W(DSTSAV) ALPHAK = DABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD UK = T - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 IF (RAD .GT. V(RAD0)) GO TO 320 C C *** SMALLER RADIUS *** LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = DMAX1(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 250 C C *** BIGGER RADIUS *** 320 IF (ALPHAK .GT. ZERO) UK = DMIN1(UK, W(UK0)) LK = DMAX1(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 250 C C *** DECIDE WHETHER TO CHECK FOR SPECIAL CASE... IN PRACTICE (FROM C *** THE STANDPOINT OF THE CALLING OPTIMIZATION CODE) IT SEEMS BEST C *** NOT TO CHECK UNTIL A FEW ITERATIONS HAVE FAILED -- HENCE THE C *** TEST ON KAMIN BELOW. C 330 DELTA = ALPHAK + DMIN1(ZERO, V(DST0)) TWOPSI = ALPHAK*DST*DST + GTSTA IF (KA .GE. KAMIN) GO TO 340 C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS C *** IT). IF (PSIFAC .GE. BIG) GO TO 340 IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370 C C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. USE ONE STEP OF INVERSE POWER METHOD WITH START C *** FROM DL7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). DL7SVN RETURNS C *** X AND W WITH L*W = X. C 340 T = DL7SVN(P, L, W(X), W) C C *** NORMALIZE W *** DO 350 I = 1, P 350 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL DL7ITV(P, W, L, W) T2 = ONE/DV2NRM(P, W) DO 360 I = 1, P 360 W(I) = T2*W(I) T = T2 * T C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = DD7TPR(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = DSQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C C *** THE ACTUAL TEST FOR THE SPECIAL CASE... C IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380 C C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE) C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE... C IF (V(DST0) .LE. ZERO) V(DST0) = DMIN1(V(DST0), T2**2 - ALPHAK) LK = DMAX1(LK, -V(DST0)) C C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT. C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * DR7MDC(3) C IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250 GO TO 270 C C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE C 380 ALPHAK = -ALPHAK V(PREDUC) = HALF * TWOPSI C C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. C T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DD7TPR(P,W(X),W))) IF (T .LT. EPS*TWOPSI/SIX) GO TO 390 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 390 DO 400 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 400 CONTINUE V(GTSTEP) = DD7TPR(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 410 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 420 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 420 CONTINUE C 999 RETURN C C *** LAST CARD OF DG7QTS FOLLOWS *** END SUBROUTINE DH2RFA(N, A, B, X, Y, Z) C C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO C *** N-VECTORS A, B *** C INTEGER N DOUBLE PRECISION A(N), B(N), X, Y, Z INTEGER I DOUBLE PRECISION T DO 10 I = 1, N T = A(I)*X + B(I)*Y A(I) = A(I) + T B(I) = B(I) + T*Z 10 CONTINUE 999 RETURN C *** LAST LINE OF DH2RFA FOLLOWS *** END DOUBLE PRECISION FUNCTION DH2RFG(A, B, X, Y, Z) C C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2 C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T, C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE DH2RFG C *** RETURNS. C DOUBLE PRECISION A, B, X, Y, Z C DOUBLE PRECISION A1, B1, C, T C/+ DOUBLE PRECISION DSQRT C/ DOUBLE PRECISION ZERO DATA ZERO/0.D+0/ C C *** BODY *** C IF (B .NE. ZERO) GO TO 10 X = ZERO Y = ZERO Z = ZERO DH2RFG = A GO TO 999 10 T = DABS(A) + DABS(B) A1 = A / T B1 = B / T C = DSQRT(A1**2 + B1**2) IF (A1 .GT. ZERO) C = -C A1 = A1 - C Z = B1 / A1 X = A1 / C Y = B1 / C DH2RFG = T * C 999 RETURN C *** LAST LINE OF DH2RFG FOLLOWS *** END SUBROUTINE DHQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, X IGH,ITN,ITS,LOW,MP2,ENM2,IERR DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N) C DOUBLE PRECISION CMPLXN(2),CMPLXD(2),CMPLXC(2) C THE ABOVE ARE TO BE USED WITH THE PORT CDDIV C ROUTINE NEEDED HERE FOR DOUBLE COMPLEX IN C PLACE OF THE RATIOS USED IN THE ORIGINAL HQR2. C THEY ARE, RESPECTIVELY, NUMERATOR, DENOMINATOR, AND COMPLEX ANSWER. C DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2 LOGICAL NOTLAS C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C H CONTAINS THE UPPER HESSENBERG MATRIX. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE C IDENTITY MATRIX. C C ON OUTPUT C C H HAS BEEN DESTROYED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C THIS ROUTINE IS FROM EISPACK (VERSION DATED AUGUST 1983), WITH C NAMES CHANGED IN ACCORDANCE WITH PORT CONVENTIONS FOR DOUBLE C PRECISION, AND WITH PROCEDURE CDIV REPLACED BY THE PORT DOUBLE- C PRECISION COMPLEX DIVISION ROUTINE, CDDIV. C C ------------------------------------------------------------------ C IERR = 0 NORM = 0.0D0 K = 1 C .......... STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM .......... DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + DABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.0D0 50 CONTINUE C EN = IGH T = 0.0D0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUES .......... 60 IF (EN .LT. LOW) GO TO 340 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = DABS(H(L-1,L-1)) + DABS(H(L,L)) IF (S .EQ. 0.0D0) S = NORM TST1 = S TST2 = TST1 + DABS(H(L,L-1)) IF (TST2 .EQ. TST1) GO TO 100 80 CONTINUE C .......... FORM SHIFT .......... 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C .......... FORM EXCEPTIONAL SHIFT .......... T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) X = 0.75D0 * S Y = X W = -0.4375D0 * S * S 130 ITS = ITS + 1 ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = DABS(P) + DABS(Q) + DABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) IF (TST2 .EQ. TST1) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.0D0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.0D0 160 CONTINUE C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN .......... DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0D0 IF (NOTLAS) R = H(K+2,K-1) X = DABS(P) + DABS(Q) + DABS(R) IF (X .EQ. 0.0D0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P IF (NOTLAS) GO TO 225 C .......... ROW MODIFICATION .......... DO 200 J = K, N P = H(K,J) + Q * H(K+1,J) H(K,J) = H(K,J) - P * X H(K+1,J) = H(K+1,J) - P * Y 200 CONTINUE C J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... DO 210 I = 1, J P = X * H(I,K) + Y * H(I,K+1) H(I,K) = H(I,K) - P H(I,K+1) = H(I,K+1) - P * Q 210 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 220 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) Z(I,K) = Z(I,K) - P Z(I,K+1) = Z(I,K+1) - P * Q 220 CONTINUE GO TO 255 225 CONTINUE C .......... ROW MODIFICATION .......... DO 230 J = K, N P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) H(K,J) = H(K,J) - P * X H(K+1,J) = H(K+1,J) - P * Y H(K+2,J) = H(K+2,J) - P * ZZ 230 CONTINUE C J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... DO 240 I = 1, J P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) H(I,K) = H(I,K) - P H(I,K+1) = H(I,K+1) - P * Q H(I,K+2) = H(I,K+2) - P * R 240 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 250 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2) Z(I,K) = Z(I,K) - P Z(I,K+1) = Z(I,K+1) - P * Q Z(I,K+2) = Z(I,K+2) - P * R 250 CONTINUE 255 CONTINUE C 260 CONTINUE C GO TO 70 C .......... ONE ROOT FOUND .......... 270 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.0D0 EN = NA GO TO 60 C .......... TWO ROOTS FOUND .......... 280 P = (Y - X) / 2.0D0 Q = P * P + W ZZ = DSQRT(DABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.0D0) GO TO 320 C .......... REAL PAIR .......... ZZ = P + DSIGN(ZZ,P) WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ WI(NA) = 0.0D0 WI(EN) = 0.0D0 X = H(EN,NA) S = DABS(X) + DABS(ZZ) P = X / S Q = ZZ / S R = DSQRT(P*P+Q*Q) P = P / R Q = Q / R C .......... ROW MODIFICATION .......... DO 290 J = NA, N ZZ = H(NA,J) H(NA,J) = Q * ZZ + P * H(EN,J) H(EN,J) = Q * H(EN,J) - P * ZZ 290 CONTINUE C .......... COLUMN MODIFICATION .......... DO 300 I = 1, EN ZZ = H(I,NA) H(I,NA) = Q * ZZ + P * H(I,EN) H(I,EN) = Q * H(I,EN) - P * ZZ 300 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 310 I = LOW, IGH ZZ = Z(I,NA) Z(I,NA) = Q * ZZ + P * Z(I,EN) Z(I,EN) = Q * Z(I,EN) - P * ZZ 310 CONTINUE C GO TO 330 C .......... COMPLEX PAIR .......... 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM .......... 340 IF (NORM .EQ. 0.0D0) GO TO 1001 C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... DO 800 NN = 1, N EN = N + 1 - NN P = WR(EN) Q = WI(EN) NA = EN - 1 IF (Q) 710, 600, 800 C .......... REAL VECTOR .......... 600 M = EN H(EN,EN) = 1.0D0 IF (NA .EQ. 0) GO TO 800 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 700 II = 1, NA I = EN - II W = H(I,I) - P R = 0.0D0 C DO 610 J = M, EN 610 R = R + H(I,J) * H(J,EN) C IF (WI(I) .GE. 0.0D0) GO TO 630 ZZ = W S = R GO TO 700 630 M = I IF (WI(I) .NE. 0.0D0) GO TO 640 T = W IF (T .NE. 0.0D0) GO TO 635 TST1 = NORM T = TST1 632 T = 0.01D0 * T TST2 = NORM + T IF (TST2 .GT. TST1) GO TO 632 635 H(I,EN) = -R / T GO TO 680 C .......... SOLVE REAL EQUATIONS .......... 640 X = H(I,I+1) Y = H(I+1,I) Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) T = (X * S - ZZ * R) / Q H(I,EN) = T IF (DABS(X) .LE. DABS(ZZ)) GO TO 650 H(I+1,EN) = (-R - W * T) / X GO TO 680 650 H(I+1,EN) = (-S - Y * T) / ZZ C C .......... OVERFLOW CONTROL .......... 680 T = DABS(H(I,EN)) IF (T .EQ. 0.0D0) GO TO 700 TST1 = T TST2 = TST1 + 1.0D0/TST1 IF (TST2 .GT. TST1) GO TO 700 DO 690 J = I, EN H(J,EN) = H(J,EN)/T 690 CONTINUE C 700 CONTINUE C .......... END REAL VECTOR .......... GO TO 800 C .......... COMPLEX VECTOR .......... 710 M = NA C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT C EIGENVECTOR MATRIX IS TRIANGULAR .......... IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720 H(NA,NA) = Q / H(EN,NA) H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) GO TO 730 720 CMPLXN(1) = 0.D0 CMPLXN(2) = -H(NA,EN) CMPLXD(1) = H(NA,NA)-P CMPLXD(2) = Q CALL CDDIV(CMPLXN,CMPLXD,CMPLXC) H(NA,NA) = CMPLXC(1) H(NA,EN) = CMPLXC(2) 730 H(EN,NA) = 0.0D0 H(EN,EN) = 1.0D0 ENM2 = NA - 1 IF (ENM2 .EQ. 0) GO TO 800 C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... DO 795 II = 1, ENM2 I = NA - II W = H(I,I) - P RA = 0.0D0 SA = 0.0D0 C DO 760 J = M, EN RA = RA + H(I,J) * H(J,NA) SA = SA + H(I,J) * H(J,EN) 760 CONTINUE C IF (WI(I) .GE. 0.0D0) GO TO 770 ZZ = W R = RA S = SA GO TO 795 770 M = I IF (WI(I) .NE. 0.0D0) GO TO 780 CMPLXN(1) = -RA CMPLXN(2) = -SA CMPLXD(1) = W CMPLXD(2) = Q CALL CDDIV(CMPLXN,CMPLXD,CMPLXC) H(I,NA) = CMPLXC(1) H(I,EN) = CMPLXC(2) GO TO 790 C .......... SOLVE COMPLEX EQUATIONS .......... 780 X = H(I,I+1) Y = H(I+1,I) VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q VI = (WR(I) - P) * 2.0D0 * Q IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784 TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X) X + DABS(Y) + DABS(ZZ)) VR = TST1 783 VR = 0.01D0 * VR TST2 = TST1 + VR IF (TST2 .GT. TST1) GO TO 783 784 CMPLXN(1) = X*R-ZZ*RA+Q*SA CMPLXN(2) = X*S-ZZ*SA-Q*RA CMPLXD(1) = VR CMPLXD(2) = VI CALL CDDIV(CMPLXN,CMPLXD,CMPLXC) H(I,NA) = CMPLXC(1) H(I,EN) = CMPLXC(2) IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785 H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X GO TO 790 785 CMPLXN(1) = -R-Y*H(I,NA) CMPLXN(2) = -S-Y*H(I,EN) CMPLXD(1) = ZZ CMPLXD(2) = Q CALL CDDIV(CMPLXN,CMPLXD,CMPLXC) H(I+1,NA) = CMPLXC(1) H(I+1,EN) = CMPLXC(2) C C .......... OVERFLOW CONTROL .......... 790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN))) IF (T .EQ. 0.0D0) GO TO 795 TST1 = T TST2 = TST1 + 1.0D0/TST1 IF (TST2 .GT. TST1) GO TO 795 DO 792 J = I, EN H(J,NA) = H(J,NA)/T H(J,EN) = H(J,EN)/T 792 CONTINUE C 795 CONTINUE C .......... END COMPLEX VECTOR .......... 800 CONTINUE C .......... END BACK SUBSTITUTION. C VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 C DO 820 J = I, N 820 Z(I,J) = H(I,J) C 840 CONTINUE C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW DO -- .......... DO 880 JJ = LOW, N J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZ = 0.0D0 C DO 860 K = LOW, M 860 ZZ = ZZ + Z(I,K) * H(K,J) C Z(I,J) = ZZ 880 CONTINUE C GO TO 1001 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE DITSUM(D, G, IV, LIV, LV, P, V, X) C C *** PRINT ITERATION SUMMARY FOR ***SOL (VERSION 2.3) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P INTEGER IV(LIV) DOUBLE PRECISION D(P), G(P), V(LV), X(P) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER ALG, I, IV1, M, NF, NG, OL, PU C/6S C REAL MODEL1(6), MODEL2(6) C/7S CHARACTER*4 MODEL1(6), MODEL2(6) C/ DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO C C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER ALGSAV, DSTNRM, F, FDIF, F0, NEEDHD, NFCALL, NFCOV, NGCOV, 1 NGCALL, NITER, NREDUC, OUTLEV, PREDUC, PRNTIT, PRUNIT, 2 RELDX, SOLPRT, STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA ALGSAV/51/, NEEDHD/36/, NFCALL/6/, NFCOV/52/, NGCALL/30/, C 1 NGCOV/53/, NITER/31/, OUTLEV/19/, PRNTIT/39/, PRUNIT/21/, C 2 SOLPRT/22/, STATPR/23/, SUSED/64/, X0PRT/24/ C/7 PARAMETER (ALGSAV=51, NEEDHD=36, NFCALL=6, NFCOV=52, NGCALL=30, 1 NGCOV=53, NITER=31, OUTLEV=19, PRNTIT=39, PRUNIT=21, 2 SOLPRT=22, STATPR=23, SUSED=64, X0PRT=24) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, PREDUC/7/, C 1 RELDX/17/, STPPAR/5/ C/7 PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, PREDUC=7, 1 RELDX=17, STPPAR=5) C/ C C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C/6S C DATA MODEL1(1)/4H /, MODEL1(2)/4H /, MODEL1(3)/4H /, C 1 MODEL1(4)/4H /, MODEL1(5)/4H G /, MODEL1(6)/4H S /, C 2 MODEL2(1)/4H G /, MODEL2(2)/4H S /, MODEL2(3)/4HG-S /, C 3 MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/ C/7S DATA MODEL1/' ',' ',' ',' ',' G ',' S '/, 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/ C/ C C------------------------------- BODY -------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IV1 = IV(1) IF (IV1 .GT. 62) IV1 = IV1 - 51 OL = IV(OUTLEV) ALG = MOD(IV(ALGSAV)-1,2) + 1 IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 370 IF (IV1 .GE. 12) GO TO 120 IF (IV1 .EQ. 2 .AND. IV(NITER) .EQ. 0) GO TO 390 IF (OL .EQ. 0) GO TO 120 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 120 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999 10 NF = IV(NFCALL) - IABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = DMAX1(DABS(V(F0)), DABS(V(F))) IF (OLDF .LE. ZERO) GO TO 20 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 20 IF (OL .GT. 0) GO TO 60 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,30) 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,40) 40 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR) IV(NEEDHD) = 0 IF (ALG .EQ. 2) GO TO 50 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR) GO TO 120 C 50 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 V(STPPAR) GO TO 120 C C *** PRINT LONG SUMMARY LINE *** C 60 IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,70) 70 FORMAT(/11H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR,2X,6HD*STEP,2X,7HNPRELDF) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,80) 80 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR,3X,6HD*STEP,3X,7HNPRELDF) IV(NEEDHD) = 0 NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF IF (ALG .EQ. 2) GO TO 90 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR), V(DSTNRM), NRELDF GO TO 120 C 90 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, 1 V(RELDX), V(STPPAR), V(DSTNRM), NRELDF 100 FORMAT(I6,I5,D10.3,2D9.2,D8.1,A3,A4,2D8.1,D9.2) 110 FORMAT(I6,I5,D11.3,2D10.2,3D9.1,D10.2) C 120 IF (IV1 .LE. 2) GO TO 999 I = IV(STATPR) IF (I .EQ. (-1)) GO TO 460 IF (I + IV1 .LT. 0) GO TO 460 GO TO (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, 1 330, 350, 500), IV1 C 130 WRITE(PU,140) 140 FORMAT(/26H ***** X-CONVERGENCE *****) GO TO 430 C 150 WRITE(PU,160) 160 FORMAT(/42H ***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 170 WRITE(PU,180) 180 FORMAT(/49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 190 WRITE(PU,200) 200 FORMAT(/42H ***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 430 C 210 WRITE(PU,220) 220 FORMAT(/33H ***** SINGULAR CONVERGENCE *****) GO TO 430 C 230 WRITE(PU,240) 240 FORMAT(/30H ***** FALSE CONVERGENCE *****) GO TO 430 C 250 WRITE(PU,260) 260 FORMAT(/38H ***** FUNCTION EVALUATION LIMIT *****) GO TO 430 C 270 WRITE(PU,280) 280 FORMAT(/28H ***** ITERATION LIMIT *****) GO TO 430 C 290 WRITE(PU,300) 300 FORMAT(/18H ***** STOPX *****) GO TO 430 C 310 WRITE(PU,320) 320 FORMAT(/44H ***** INITIAL F(X) CANNOT BE COMPUTED *****) C GO TO 390 C 330 WRITE(PU,340) 340 FORMAT(/37H ***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 350 WRITE(PU,360) 360 FORMAT(/43H ***** GRADIENT COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 460 GO TO 390 C 370 WRITE(PU,380) IV(1) 380 FORMAT(/14H ***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON DITSUM *** C 390 IF (IV(X0PRT) .NE. 0) WRITE(PU,400) (I, X(I), D(I), I = 1, P) 400 FORMAT(/23H I INITIAL X(I),8X,4HD(I)//(1X,I5,D17.6,D14.3)) C *** THE FOLLOWING ARE TO AVOID UNDEFINED VARIABLES WHEN THE C *** FUNCTION EVALUATION LIMIT IS 1... V(DSTNRM) = ZERO V(FDIF) = ZERO V(NREDUC) = ZERO V(PREDUC) = ZERO V(RELDX) = ZERO IF (IV1 .GE. 12) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0 .AND. ALG .EQ. 1) WRITE(PU,30) IF (OL .LT. 0 .AND. ALG .EQ. 2) WRITE(PU,40) IF (OL .GT. 0 .AND. ALG .EQ. 1) WRITE(PU,70) IF (OL .GT. 0 .AND. ALG .EQ. 2) WRITE(PU,80) IF (ALG .EQ. 1) WRITE(PU,410) IV(NFCALL), V(F) IF (ALG .EQ. 2) WRITE(PU,420) IV(NFCALL), V(F) 410 FORMAT(/6H 0,I5,D10.3) 420 FORMAT(/6H 0,I5,D11.3) GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 430 IV(NEEDHD) = 1 IF (IV(STATPR) .LE. 0) GO TO 460 OLDF = DMAX1(DABS(V(F0)), DABS(V(F))) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 440 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 440 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(PU,450) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 450 FORMAT(/9H FUNCTION,D17.6,8H RELDX,D17.3/12H FUNC. EVALS, 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,D16.3,6X,7HNPRELDF,D15.3) C 460 IF (IV(SOLPRT) .EQ. 0) GO TO 999 IV(NEEDHD) = 1 IF (IV(ALGSAV) .GT. 2) GO TO 999 WRITE(PU,470) 470 FORMAT(/22H I FINAL X(I),8X,4HD(I),10X,4HG(I)/) DO 480 I = 1, P 480 WRITE(PU,490) I, X(I), D(I), G(I) 490 FORMAT(1X,I5,D16.6,2D14.3) GO TO 999 C 500 WRITE(PU,510) 510 FORMAT(/24H INCONSISTENT DIMENSIONS) 999 RETURN C *** LAST CARD OF DITSUM FOLLOWS *** END SUBROUTINE DIVSET(ALG, IV, LIV, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER LIV, LV INTEGER ALG, IV(LIV) DOUBLE PRECISION V(LV) C INTEGER I7MDCN EXTERNAL I7MDCN,DV7DFL C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS. C DV7DFL.... PROVIDES DEFAULT VALUES TO V. C INTEGER ALG1, MIV, MV INTEGER MINIV(4), MINV(4) C C *** SUBSCRIPTS FOR IV *** C INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH, 1 INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL, 2 MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT, 3 PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR, 4 VNEED, VSAVE, X0PRT C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA ALGSAV/51/, COVPRT/14/, COVREQ/15/, DRADPR/101/, DTYPE/16/, C 1 HC/71/, IERR/75/, INITH/25/, INITS/25/, IPIVOT/76/, C 2 IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/, MXFCAL/17/, C 3 MXITER/18/, NFCOV/52/, NGCOV/53/, NVDFLT/50/, NVSAVE/9/, C 4 OUTLEV/19/, PARPRT/20/, PARSAV/49/, PERM/58/, PRUNIT/21/, C 5 QRTYP/80/, RDREQ/57/, RMAT/78/, SOLPRT/22/, STATPR/23/, C 6 VNEED/4/, VSAVE/60/, X0PRT/24/ C/7 PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16, 1 HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76, 2 IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17, 3 MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9, 4 OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21, 5 QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23, 6 VNEED=4, VSAVE=60, X0PRT=24) C/ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/, 1 MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/ C C------------------------------- BODY -------------------------------- C IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1) IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40 MIV = MINIV(ALG) IF (LIV .LT. MIV) GO TO 20 MV = MINV(ALG) IF (LV .LT. MV) GO TO 30 ALG1 = MOD(ALG-1,2) + 1 CALL DV7DFL(ALG1, LV, V) IV(1) = 12 IF (ALG .GT. 2) IV(DRADPR) = 1 IV(IVNEED) = 0 IV(LASTIV) = MIV IV(LASTV) = MV IV(LMAT) = MV + 1 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PERM) = MIV + 1 IV(SOLPRT) = 1 IV(STATPR) = 1 IV(VNEED) = 0 IV(X0PRT) = 1 C IF (ALG1 .GE. 2) GO TO 10 C C *** REGRESSION VALUES C IV(COVPRT) = 3 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(HC) = 0 IV(IERR) = 0 IV(INITS) = 0 IV(IPIVOT) = 0 IV(NVDFLT) = 32 IV(VSAVE) = 58 IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3 IV(PARSAV) = IV(VSAVE) + NVSAVE IV(QRTYP) = 1 IV(RDREQ) = 3 IV(RMAT) = 0 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 IV(DTYPE) = 0 IV(INITH) = 1 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(NVDFLT) = 25 IV(PARSAV) = 47 IF (ALG .GT. 2) IV(PARSAV) = 61 GO TO 999 C 20 IV(1) = 15 GO TO 999 C 30 IV(1) = 16 GO TO 999 C 40 IV(1) = 67 C 999 RETURN C *** LAST CARD OF DIVSET FOLLOWS *** END SUBROUTINE DL7ITV(N, X, L, Y) C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 DOUBLE PRECISION XI, ZERO C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST CARD OF DL7ITV FOLLOWS *** END SUBROUTINE DL7IVM(N, X, L, Y) C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR INTEGER I, J, K DOUBLE PRECISION T, ZERO C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C DO 10 K = 1, N IF (Y(K) .NE. ZERO) GO TO 20 X(K) = ZERO 10 CONTINUE GO TO 999 20 J = K*(K+1)/2 X(K) = Y(K) / L(J) IF (K .GE. N) GO TO 999 K = K + 1 DO 30 I = K, N T = DD7TPR(I-1, L(J+1), X) J = J + I X(I) = (Y(I) - T)/L(J) 30 CONTINUE 999 RETURN C *** LAST CARD OF DL7IVM FOLLOWS *** END SUBROUTINE DL7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT, 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V, 2 W, WLM, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER IERR, KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) DOUBLE PRECISION B(2,P), D(P), G(P), LMAT(1), QTR(P), RMAT(1), 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(1), 2 X0(P), X(P) C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4) C DOUBLE PRECISION DD7TPR EXTERNAL DD7MLP, DD7TPR, DL7MST, DL7TVM, DQ7RSH, DS7BQN, 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP C C *** LOCAL VARIABLES *** C INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11 DOUBLE PRECISION DS0, NRED, PRED, RAD DOUBLE PRECISION ONE, ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C C/6 C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/, C 1 RADIUS/8/ C/7 PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) C/ DATA ONE/1.D+0/, ZERO/0.D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C P1 = PC IF (KA .LT. 0) GO TO 10 NRED = V(NREDUC) DS0 = V(DST0) GO TO 20 10 P0 = 0 KA = -1 C 20 KINIT = -1 IF (P0 .EQ. P1) KINIT = KA CALL DV7CPY(P, X, X0) CALL DV7CPY(P, TD, D) C *** USE STEP(1,3) AS TEMP. COPY OF QTR *** CALL DV7CPY(P, STEP(1,3), QTR) CALL DV7IPR(P, IPIV, TD) PRED = ZERO RAD = V(RADIUS) KB = -1 V(DSTNRM) = ZERO IF (P1 .GT. 0) GO TO 30 NRED = ZERO DS0 = ZERO CALL DV7SCP(P, STEP, ZERO) GO TO 90 C 30 CALL DV7VMP(P, TG, G, D, -1) CALL DV7IPR(P, IPIV, TG) P10 = P1 40 K = KINIT KINIT = -1 V(RADIUS) = RAD - V(DSTNRM) CALL DV7VMP(P1, TG, TG, TD, 1) DO 50 I = 1, P1 50 IPIV1(I) = I K0 = MAX0(0, K) CALL DL7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP, 1 V, WLM) CALL DV7VMP(P1, TG, TG, TD, -1) P0 = P1 IF (KA .GE. 0) GO TO 60 NRED = V(NREDUC) DS0 = V(DST0) C 60 KA = K V(RADIUS) = RAD L = P1 + 5 IF (K .LE. K0) CALL DD7MLP(P1, LMAT, TD, RMAT, -1) IF (K .GT. K0) CALL DD7MLP(P1, LMAT, TD, WLM(L), -1) CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT, 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0) PRED = PRED + V(PREDUC) IF (NS .EQ. 0) GO TO 80 P0 = 0 C C *** UPDATE RMAT AND QTR *** C P11 = P1 + 1 L = P10 + P11 DO 70 K = P11, P10 J = L - K I = IPIV2(J) IF (I .LT. J) CALL DQ7RSH(I, J, .TRUE., QTR, RMAT, W) 70 CONTINUE C 80 IF (KB .GT. 0) GO TO 90 C C *** UPDATE LOCAL COPY OF QTR *** C CALL DV7VMP(P10, W, STEP(1,2), TD, -1) CALL DL7TVM(P10, W, LMAT, W) CALL DV2AXY(P10, STEP(1,3), ONE, W, QTR) GO TO 40 C 90 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = DD7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF DL7MSB FOLLOWS *** END SUBROUTINE DL7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, KA, P INTEGER IPIVOT(P) DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR DQ7RGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR DQ7RGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C DL7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C DL7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C DL7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DV7CPY - COPIES ONE VECTOR TO ANOTHER. C DV2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, 1 TTOL, ZERO DOUBLE PRECISION BIG C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DL7SVN, DR7MDC, DV2NRM EXTERNAL DD7TPR, DL7ITV, DL7IVM, DL7SVN, DR7MDC,DV7CPY, DV2NRM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR C/6 C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/, C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/, C 2 RAD0/9/, STPPAR/5/ C/7 PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4, 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8, 2 RAD0=9, STPPAR=5) C/ C C/6 C DATA DFAC/256.D+0/, EIGHT/8.D+0/, HALF/0.5D+0/, NEGONE/-1.D+0/, C 1 ONE/1.D+0/, P001/1.D-3/, THREE/3.D+0/, TTOL/2.5D+0/, C 2 ZERO/0.D+0/ C/7 PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0, 1 ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0, 2 ZERO=0.D+0) SAVE BIG C/ DATA BIG/0.D+0/ C C *** BODY *** C C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK, C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J) C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0), C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY. LK0 = P + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 RMAT0 = DSTSAV C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER C *** WORK ON THESE COPIES. RMAT = RMAT0 + 1 PP1O2 = P * (P + 1) / 2 RES0 = PP1O2 + RMAT0 RES = RES0 + 1 RAD = V(RADIUS) IF (RAD .GT. ZERO) 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2) IF (BIG .LE. ZERO) BIG = DR7MDC(6) PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION. DTOL = ONE/DFAC DFACSQ = DFAC*DFAC C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO LK = ZERO UK = ZERO KALIM = KA + 12 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 V(NREDUC) = HALF*DD7TPR(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 T = DL7SVN(P, R, STEP, W(RES)) IF (T .GE. ONE) GO TO 30 IF (DV2NRM(P, QTR) .GE. BIG*T) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING DL7ITV AND DL7IVM. 30 CALL DL7ITV(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = DV2NRM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL DL7IVM(P, STEP, R, STEP) T = ONE / DV2NRM(P, STEP) W(PHIPIN) = (T/RAD)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = DV2NRM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. C ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = DMIN1(UK, DMAX1(ALPHAK, LK)) C C C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES *** C 110 KA = KA + 1 CALL DV7CPY(PP1O2, W(RMAT), R) CALL DV7CPY(P, W(RES), QTR) C C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. *** C IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK SQRTAK = DSQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. DABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P SI = STEP(I1-1) IF (SI .EQ. ZERO) GO TO 260 L = I1*(I1+1)/2 + RMAT0 WL = W(L) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF (DABS(SI) .GT. DABS(WL)) GO TO 220 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL DL7ITV(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = DV2NRM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - DD7TPR(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL DL7IVM(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / DSQRT(W(I)) T = ONE / DV2NRM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = DMAX1(LK, ALPHAK) ALPHAK = LK GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = DABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** BIGGER RADIUS *** 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T LK = ZERO IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = DMIN1(DD7TPR(P,STEP,G), ZERO) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C 999 RETURN C C *** LAST CARD OF DL7MST FOLLOWS *** END SUBROUTINE DL7NVR(N, LIN, L) C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C *** PARAMETERS *** C INTEGER N DOUBLE PRECISION L(1), LIN(1) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 DOUBLE PRECISION ONE, T, ZERO C/6 C DATA ONE/1.D+0/, ZERO/0.D+0/ C/7 PARAMETER (ONE=1.D+0, ZERO=0.D+0) C/ C C *** BODY *** C NP1 = N + 1 J0 = N*(NP1)/2 DO 30 II = 1, N I = NP1 - II LIN(J0) = ONE/L(J0) IF (I .LE. 1) GO TO 999 J1 = J0 IM1 = I - 1 DO 20 JJ = 1, IM1 T = ZERO J0 = J1 K0 = J1 - JJ DO 10 K = 1, JJ T = T - L(K0)*LIN(J0) J0 = J0 - 1 K0 = K0 + K - I 10 CONTINUE LIN(J0) = T/L(K0) 20 CONTINUE J0 = J0 - 1 30 CONTINUE 999 RETURN C *** LAST CARD OF DL7NVR FOLLOWS *** END SUBROUTINE DL7SQR(N, A, L) C C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE C *** SAME STORAGE. C C *** PARAMETERS *** C INTEGER N DOUBLE PRECISION A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1 DOUBLE PRECISION T C NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II IP1 = I + 1 I0 = I0 - I J0 = I*(I+1)/2 DO 20 JJ = 1, I J = IP1 - JJ J0 = J0 - J T = 0.0D0 DO 10 K = 1, J IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE IJ = I0 + J A(IJ) = T 20 CONTINUE 30 CONTINUE 999 RETURN END SUBROUTINE DL7SRT(N1, N, L, A, IRC) C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C *** PARAMETERS *** C INTEGER N1, N, IRC DOUBLE PRECISION L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K DOUBLE PRECISION T, TD, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C C *** BODY *** C I0 = N1 * (N1 - 1) / 2 DO 50 I = N1, N TD = ZERO IF (I .EQ. 1) GO TO 40 J0 = 0 IM1 = I - 1 DO 30 J = 1, IM1 T = ZERO IF (J .EQ. 1) GO TO 20 JM1 = J - 1 DO 10 K = 1, JM1 IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE 20 IJ = I0 + J J0 = J0 + J T = (A(IJ) - T) / L(J0) L(IJ) = T TD = TD + T*T 30 CONTINUE 40 I0 = I0 + I T = A(I0) - TD IF (T .LE. ZERO) GO TO 60 L(I0) = DSQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST CARD OF DL7SRT *** END DOUBLE PRECISION FUNCTION DL7SVN(P, L, X, Y) C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF DL7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF DL7SVN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO DL7SVN RETURNS). C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C DL7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1 DOUBLE PRECISION B, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C DOUBLE PRECISION HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DD7TPR, DV2NRM,DV2AXY C C/6 C DATA HALF/0.5D+0/, ONE/1.D+0/, R9973/9973.D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0) C/ C C *** BODY *** C IX = 2 PM1 = P - 1 C C *** FIRST CHECK WHETHER TO RETURN DL7SVN = 0 AND INITIALIZE X *** C II = 0 J0 = P*PM1/2 JJ = J0 + P IF (L(JJ) .EQ. ZERO) GO TO 110 IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = B / L(JJ) X(P) = XPLUS IF (P .LE. 1) GO TO 60 DO 10 I = 1, PM1 II = II + I IF (L(II) .EQ. ZERO) GO TO 110 JI = J0 + I X(I) = XPLUS * L(JI) 10 CONTINUE C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 50 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = DABS(XPLUS) SMINUS = DABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + DABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + DABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .GT. 0) CALL DV2AXY(JM1, X, XPLUS, L(J0+1), X) 50 CONTINUE C C *** NORMALIZE X *** C 60 T = ONE/DV2NRM(P, X) DO 70 I = 1, P 70 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN DL7SVN = 1/TWONORM(Y) *** C DO 100 J = 1, P JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J T = ZERO IF (JM1 .GT. 0) T = DD7TPR(JM1, L(J0+1), Y) Y(J) = (X(J) - T) / L(JJ) 100 CONTINUE C DL7SVN = ONE/DV2NRM(P, Y) GO TO 999 C 110 DL7SVN = ZERO 999 RETURN C *** LAST CARD OF DL7SVN FOLLOWS *** END DOUBLE PRECISION FUNCTION DL7SVX(P, L, X, Y) C C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS C APPROXIMATION MAY BE CRUDE. C Y (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND- C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X C OVER-WRITES Y. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1 DOUBLE PRECISION B, BLJI, SMINUS, SPLUS, T, YI C C *** CONSTANTS *** C DOUBLE PRECISION HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DD7TPR, DV2NRM,DV2AXY C C/6 C DATA HALF/0.5D+0/, ONE/1.D+0/, R9973/9973.D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0) C/ C C *** BODY *** C IX = 2 PPLUS1 = P + 1 PM1 = P - 1 C C *** FIRST INITIALIZE X TO PARTIAL SUMS *** C J0 = P*PM1/2 JJ = J0 + P IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) X(P) = B * L(JJ) IF (P .LE. 1) GO TO 40 DO 10 I = 1, PM1 JI = J0 + I X(I) = B * L(JI) 10 CONTINUE C C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 30 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) JM1 = J - 1 J0 = J*JM1/2 SPLUS = ZERO SMINUS = ZERO DO 20 I = 1, J JI = J0 + I BLJI = B * L(JI) SPLUS = SPLUS + DABS(BLJI + X(I)) SMINUS = SMINUS + DABS(BLJI - X(I)) 20 CONTINUE IF (SMINUS .GT. SPLUS) B = -B X(J) = ZERO C *** UPDATE PARTIAL SUMS *** CALL DV2AXY(J, X, B, L(J0+1), X) 30 CONTINUE C C *** NORMALIZE X *** C 40 T = DV2NRM(P, X) IF (T .LE. ZERO) GO TO 80 T = ONE / T DO 50 I = 1, P 50 X(I) = T*X(I) C C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) *** C DO 60 JJJ = 1, P J = PPLUS1 - JJJ JI = J*(J-1)/2 + 1 Y(J) = DD7TPR(J, L(JI), X) 60 CONTINUE C C *** NORMALIZE Y AND SET X = (L**T)*Y *** C T = ONE / DV2NRM(P, Y) JI = 1 DO 70 I = 1, P YI = T * Y(I) X(I) = ZERO CALL DV2AXY(I, X, YI, L(JI), X) JI = JI + I 70 CONTINUE DL7SVX = DV2NRM(P, X) GO TO 999 C 80 DL7SVX = ZERO C 999 RETURN C *** LAST CARD OF DL7SVX FOLLOWS *** END SUBROUTINE DL7TSQ(N, A, L) C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C INTEGER N DOUBLE PRECISION A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C INTEGER I, II, IIM1, I1, J, K, M DOUBLE PRECISION LII, LJ C II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C 999 RETURN C *** LAST CARD OF DL7TSQ FOLLOWS *** END SUBROUTINE DL7TVM(N, X, L, Y) C C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY C *** OCCUPY THE SAME STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, IJ, I0, J DOUBLE PRECISION YI, ZERO C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C I0 = 0 DO 20 I = 1, N YI = Y(I) X(I) = ZERO DO 10 J = 1, I IJ = I0 + J X(J) = X(J) + YI*L(IJ) 10 CONTINUE I0 = I0 + I 20 CONTINUE 999 RETURN C *** LAST CARD OF DL7TVM FOLLOWS *** END SUBROUTINE DL7UPD(BETA, GAMMA, L, LAMBDA, LPLUS, N, W, Z) C C *** COMPUTE LPLUS = SECANT UPDATE OF L *** C C *** PARAMETER DECLARATIONS *** C INTEGER N DOUBLE PRECISION BETA(N), GAMMA(N), L(1), LAMBDA(N), LPLUS(1), 1 W(N), Z(N) C DIMENSION L(N*(N+1)/2), LPLUS(N*(N+1)/2) C C-------------------------- PARAMETER USAGE -------------------------- C C BETA = SCRATCH VECTOR. C GAMMA = SCRATCH VECTOR. C L (INPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE. C LAMBDA = SCRATCH VECTOR. C LPLUS (OUTPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE, WHICH MAY C OCCUPY THE SAME STORAGE AS L. C N (INPUT) LENGTH OF VECTOR PARAMETERS AND ORDER OF MATRICES. C W (INPUT, DESTROYED ON OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 C CORRECTION TO L. C Z (INPUT, DESTROYED ON OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 C CORRECTION TO L. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE UPDATES THE CHOLESKY FACTOR L OF A SYMMETRIC C POSITIVE DEFINITE MATRIX TO WHICH A SECANT UPDATE IS BEING C APPLIED -- IT COMPUTES A CHOLESKY FACTOR LPLUS OF C L * (I + Z*W**T) * (I + W*Z**T) * L**T. IT IS ASSUMED THAT W C AND Z HAVE BEEN CHOSEN SO THAT THE UPDATED MATRIX IS STRICTLY C POSITIVE DEFINITE. C C *** ALGORITHM NOTES *** C C THIS CODE USES RECURRENCE 3 OF REF. 1 (WITH D(J) = 1 FOR ALL J) C TO COMPUTE LPLUS OF THE FORM L * (I + Z*W**T) * Q, WHERE Q C IS AN ORTHOGONAL MATRIX THAT MAKES THE RESULT LOWER TRIANGULAR. C LPLUS MAY HAVE SOME NEGATIVE DIAGONAL ELEMENTS. C C *** REFERENCES *** C C 1. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON- C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811. C C *** GENERAL *** C C CODED BY DAVID M. GAY (FALL 1979). C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I, IJ, J, JJ, JP1, K, NM1, NP1 DOUBLE PRECISION A, B, BJ, ETA, GJ, LJ, LIJ, LJJ, NU, S, THETA, 1 WJ, ZJ DOUBLE PRECISION ONE, ZERO C C *** DATA INITIALIZATIONS *** C C/6 C DATA ONE/1.D+0/, ZERO/0.D+0/ C/7 PARAMETER (ONE=1.D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NU = ONE ETA = ZERO IF (N .LE. 1) GO TO 30 NM1 = N - 1 C C *** TEMPORARILY STORE S(J) = SUM OVER K = J+1 TO N OF W(K)**2 IN C *** LAMBDA(J). C S = ZERO DO 10 I = 1, NM1 J = N - I S = S + W(J+1)**2 LAMBDA(J) = S 10 CONTINUE C C *** COMPUTE LAMBDA, GAMMA, AND BETA BY GOLDFARB*S RECURRENCE 3. C DO 20 J = 1, NM1 WJ = W(J) A = NU*Z(J) - ETA*WJ THETA = ONE + A*WJ S = A*LAMBDA(J) LJ = DSQRT(THETA**2 + A*S) IF (THETA .GT. ZERO) LJ = -LJ LAMBDA(J) = LJ B = THETA*WJ + S GAMMA(J) = B * NU / LJ BETA(J) = (A - B*ETA) / LJ NU = -NU / LJ ETA = -(ETA + (A**2)/(THETA - LJ)) / LJ 20 CONTINUE 30 LAMBDA(N) = ONE + (NU*Z(N) - ETA*W(N))*W(N) C C *** UPDATE L, GRADUALLY OVERWRITING W AND Z WITH L*W AND L*Z. C NP1 = N + 1 JJ = N * (N + 1) / 2 DO 60 K = 1, N J = NP1 - K LJ = LAMBDA(J) LJJ = L(JJ) LPLUS(JJ) = LJ * LJJ WJ = W(J) W(J) = LJJ * WJ ZJ = Z(J) Z(J) = LJJ * ZJ IF (K .EQ. 1) GO TO 50 BJ = BETA(J) GJ = GAMMA(J) IJ = JJ + J JP1 = J + 1 DO 40 I = JP1, N LIJ = L(IJ) LPLUS(IJ) = LJ*LIJ + BJ*W(I) + GJ*Z(I) W(I) = W(I) + LIJ*WJ Z(I) = Z(I) + LIJ*ZJ IJ = IJ + I 40 CONTINUE 50 JJ = JJ - J 60 CONTINUE C 999 RETURN C *** LAST CARD OF DL7UPD FOLLOWS *** END SUBROUTINE DL7VML(N, X, L, Y) C C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, II, IJ, I0, J, NP1 DOUBLE PRECISION T, ZERO C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C NP1 = N + 1 I0 = N*(N+1)/2 DO 20 II = 1, N I = NP1 - II I0 = I0 - I T = ZERO DO 10 J = 1, I IJ = I0 + J T = T + L(IJ)*Y(J) 10 CONTINUE X(I) = T 20 CONTINUE 999 RETURN C *** LAST CARD OF DL7VML FOLLOWS *** END SUBROUTINE DMNF(N, D, X, CALCF, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER N, LIV, LV INTEGER IV(LIV), UIPARM(1) DOUBLE PRECISION D(N), X(N), V(LV), URPARM(1) C DIMENSION V(77 + N*(N+17)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, UFPARM C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNF IN AN ATTEMPT C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR DMNF ARE THE SAME AS THOSE FOR DMNG C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X, C DMNF CALLS DS7GRD, WHICH COMPUTES AN APPROXIMATION TO THE C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST C IN THIS REGARD (AND IS NOT DESCRIBED IN DMNG). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR DMNF THAN FOR DMNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCE *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, C AND MCS-7906671. C C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL DRMNF C C DRMNF.... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND C CALLS DRMNG TO CARRY OUT DMNG ALGORITHM. C INTEGER NF DOUBLE PRECISION FX C C *** SUBSCRIPTS FOR IV *** C INTEGER NFCALL, TOOBIG C C/6 C DATA NFCALL/6/, TOOBIG/2/ C/7 PARAMETER (NFCALL=6, TOOBIG=2) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C 10 CALL DRMNF(D, FX, IV, LIV, LV, N, V, X) IF (IV(1) .GT. 2) GO TO 999 C C *** COMPUTE FUNCTION *** C NF = IV(NFCALL) CALL CALCF(N, X, NF, FX, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 10 C C 999 RETURN C *** LAST CARD OF DMNF FOLLOWS *** END SUBROUTINE DMNFB(P, D, X, B, CALCF, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER P, LIV, LV C/6S C INTEGER IV(LIV), UIPARM(1) C DOUBLE PRECISION B(2,P), D(P), X(P), V(LV), URPARM(1) C/7S INTEGER IV(LIV), UIPARM(*) DOUBLE PRECISION B(2,P), D(P), X(P), V(LV), URPARM(*) C/ C DIMENSION V(59 + P), V(77 + P*(P+23)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, UFPARM C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNF IN AN ATTEMPT C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR DMNFB ARE THE SAME AS THOSE FOR DMNGB C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X, C DMNFB CALLS DS3GRD, WHICH COMPUTES AN APPROXIMATION TO THE C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST C IN THIS REGARD (AND IS NOT DESCRIBED IN DMNG OR DMNGB). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR DMNFB THAN FOR DMNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCE *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, C AND MCS-7906671. C C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL DRMNFB C C DRMNFB... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND C CALLS DRMNG TO CARRY OUT DMNG ALGORITHM. C INTEGER NF DOUBLE PRECISION FX C C *** SUBSCRIPTS FOR IV *** C INTEGER NFCALL, TOOBIG C C/6 C DATA NFCALL/6/, TOOBIG/2/ C/7 PARAMETER (NFCALL=6, TOOBIG=2) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C 10 CALL DRMNFB(B, D, FX, IV, LIV, LV, P, V, X) IF (IV(1) .GT. 2) GO TO 999 C C *** COMPUTE FUNCTION *** C NF = IV(NFCALL) CALL CALCF(P, X, NF, FX, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 10 C C 999 RETURN C *** LAST CARD OF DMNFB FOLLOWS *** END SUBROUTINE DMNG(N, D, X, CALCF, CALCG, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING *** C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE *** C INTEGER N, LIV, LV INTEGER IV(LIV), UIPARM(1) DOUBLE PRECISION D(N), X(N), V(LV), URPARM(1) C DIMENSION V(71 + N*(N+15)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, CALCG, UFPARM C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNG IN AN ATTEMPT C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C-------------------------- PARAMETER USAGE -------------------------- C C N........ (INPUT) THE NUMBER OF VARIABLES ON WHICH F DEPENDS, I.E., C THE NUMBER OF COMPONENTS IN X. C D........ (INPUT/OUTPUT) A SCALE VECTOR SUCH THAT D(I)*X(I), C I = 1,2,...,N, ARE ALL IN COMPARABLE UNITS. C D CAN STRONGLY AFFECT THE BEHAVIOR OF DMNG. C FINDING THE BEST CHOICE OF D IS GENERALLY A TRIAL- C AND-ERROR PROCESS. CHOOSING D SO THAT D(I)*X(I) C HAS ABOUT THE SAME VALUE FOR ALL I OFTEN WORKS WELL. C THE DEFAULTS PROVIDED BY SUBROUTINE DIVSET (SEE IV C BELOW) REQUIRE THE CALLER TO SUPPLY D. C X........ (INPUT/OUTPUT) BEFORE (INITIALLY) CALLING DMNG, THE CALL- C ER SHOULD SET X TO AN INITIAL GUESS AT X*. WHEN C DMNG RETURNS, X CONTAINS THE BEST POINT SO FAR C FOUND, I.E., THE ONE THAT GIVES THE LEAST VALUE SO C FAR SEEN FOR F(X). C CALCF.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES F(X). CALCF C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C IT IS INVOKED BY C CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) C WHEN CALCF IS CALLED, NF IS THE INVOCATION C COUNT FOR CALCF. NF IS INCLUDED FOR POSSIBLE USE C WITH CALCG. IF X IS OUT OF BOUNDS (E.G., IF IT C WOULD CAUSE OVERFLOW IN COMPUTING F(X)), THEN CALCF C SHOULD SET NF TO 0. THIS WILL CAUSE A SHORTER STEP C TO BE ATTEMPTED. (IF X IS IN BOUNDS, THEN CALCF C SHOULD NOT CHANGE NF.) THE OTHER PARAMETERS ARE AS C DESCRIBED ABOVE AND BELOW. CALCF SHOULD NOT CHANGE C N, P, OR X. C CALCG.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES G(X), THE GRA- C DIENT OF F AT X. CALCG MUST BE DECLARED EXTERNAL IN C THE CALLING PROGRAM. IT IS INVOKED BY C CALL CALCG(N, X, NF, G, UIPARM, URPARM, UFAPRM) C WHEN CALCG IS CALLED, NF IS THE INVOCATION C COUNT FOR CALCF AT THE TIME F(X) WAS EVALUATED. THE C X PASSED TO CALCG IS USUALLY THE ONE PASSED TO CALCF C ON EITHER ITS MOST RECENT INVOCATION OR THE ONE C PRIOR TO IT. IF CALCF SAVES INTERMEDIATE RESULTS C FOR USE BY CALCG, THEN IT IS POSSIBLE TO TELL FROM C NF WHETHER THEY ARE VALID FOR THE CURRENT X (OR C WHICH COPY IS VALID IF TWO COPIES ARE KEPT). IF G C CANNOT BE COMPUTED AT X, THEN CALCG SHOULD SET NF TO C 0. IN THIS CASE, DMNG WILL RETURN WITH IV(1) = 65. C (IF G CAN BE COMPUTED AT X, THEN CALCG SHOULD NOT C CHANGED NF.) THE OTHER PARAMETERS TO CALCG ARE AS C DESCRIBED ABOVE AND BELOW. CALCG SHOULD NOT CHANGE C N OR X. C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH LIV (SEE C BELOW) THAT HELPS CONTROL THE DMNG ALGORITHM AND C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI- C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/ C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC- C TION EVALUATIONS. SEE THE SECTION ON IV INPUT C VALUES BELOW. C LIV...... (INPUT) LENGTH OF IV ARRAY. MUST BE AT LEAST 60. IF LIV C IS TOO SMALL, THEN DMNG RETURNS WITH IV(1) = 15. C WHEN DMNG RETURNS, THE SMALLEST ALLOWED VALUE OF C LIV IS STORED IN IV(LASTIV) -- SEE THE SECTION ON C IV OUTPUT VALUES BELOW. (THIS IS INTENDED FOR USE C WITH EXTENSIONS OF DMNG THAT HANDLE CONSTRAINTS.) C LV....... (INPUT) LENGTH OF V ARRAY. MUST BE AT LEAST 71+N*(N+15)/2. C (AT LEAST 77+N*(N+17)/2 FOR DMNF, AT LEAST C 78+N*(N+12) FOR DMNH). IF LV IS TOO SMALL, THEN C DMNG RETURNS WITH IV(1) = 16. WHEN DMNG RETURNS, C THE SMALLEST ALLOWED VALUE OF LV IS STORED IN C IV(LASTV) -- SEE THE SECTION ON IV OUTPUT VALUES C BELOW. C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH LV C (SEE BELOW) THAT HELPS CONTROL THE DMNG ALGORITHM C AND THAT IS USED TO STORE VARIOUS INTERMEDIATE C QUANTITIES. OF PARTICULAR INTEREST ARE THE ENTRIES C IN V THAT LIMIT THE LENGTH OF THE FIRST STEP C ATTEMPTED (LMAX0) AND SPECIFY CONVERGENCE TOLERANCES C (AFCTOL, LMAXS, RFCTOL, SCTOL, XCTOL, XFTOL). C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE C TO CALCF AND CALCG. C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT C CHANGE TO CALCF AND CALCG. C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT C CHANGE TO CALCF AND CALCG. C C *** IV INPUT VALUES (FROM SUBROUTINE DIVSET) *** C C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 14...... C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT C DIVSET(2, IV, LIV, LV, V) C IS TO BE CALLED TO PROVIDE ALL DEFAULT VALUES TO IV AND C V. 12 (THE VALUE THAT DIVSET ASSIGNS TO IV(1)) MEANS THE C CALLER HAS ALREADY CALLED DIVSET AND HAS POSSIBLY CHANGED C SOME IV AND/OR V ENTRIES TO NON-DEFAULT VALUES. C 13 MEANS DIVSET HAS BEEN CALLED AND THAT DMNG (AND C DRMNG) SHOULD ONLY DO THEIR STORAGE ALLOCATION. THAT IS, C THEY SHOULD SET THE OUTPUT COMPONENTS OF IV THAT TELL C WHERE VARIOUS SUBARRAYS ARRAYS OF V BEGIN, SUCH AS IV(G) C (AND, FOR DMNH AND DRMNH ONLY, IV(DTOL)), AND RETURN. C 14 MEANS THAT A STORAGE HAS BEEN ALLOCATED (BY A CALL C WITH IV(1) = 13) AND THAT THE ALGORITHM SHOULD BE C STARTED. WHEN CALLED WITH IV(1) = 13, DMNG RETURNS C IV(1) = 14 UNLESS LIV OR LV IS TOO SMALL (OR N IS NOT C POSITIVE). DEFAULT = 12. C IV(INITH).... IV(25) TELLS WHETHER THE HESSIAN APPROXIMATION H SHOULD C BE INITIALIZED. 1 (THE DEFAULT) MEANS DRMNG SHOULD C INITIALIZE H TO THE DIAGONAL MATRIX WHOSE I-TH DIAGONAL C ELEMENT IS D(I)**2. 0 MEANS THE CALLER HAS SUPPLIED A C CHOLESKY FACTOR L OF THE INITIAL HESSIAN APPROXIMATION C H = L*(L**T) IN V, STARTING AT V(IV(LMAT)) = V(IV(42)) C (AND STORED COMPACTLY BY ROWS). NOTE THAT IV(LMAT) MAY C BE INITIALIZED BY CALLING DMNG WITH IV(1) = 13 (SEE C THE IV(1) DISCUSSION ABOVE). DEFAULT = 1. C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS C (CALLS ON CALCF) ALLOWED. IF THIS NUMBER DOES NOT SUF- C FICE, THEN DMNG RETURNS WITH IV(1) = 9. DEFAULT = 200. C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA- C TIONS (CALLS ON CALCG) TO IV(MXITER) + 1. IF IV(MXITER) C ITERATIONS DO NOT SUFFICE, THEN DMNG RETURNS WITH C IV(1) = 10. DEFAULT = 150. C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM- C MARY LINES PRINTED (BY DITSUM). IV(OUTLEV) = 0 MEANS DO C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV) C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 78 (PLUS CARRI- C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE C ITERATION AND FUNCTION EVALUATION COUNTS, F = THE CURRENT C FUNCTION VALUE, RELATIVE DIFFERENCE IN FUNCTION VALUES C ACHIEVED BY THE LATEST STEP (I.E., RELDF = (F0-V(F))/F01, C WHERE F01 IS THE MAXIMUM OF ABS(V(F)) AND ABS(V(F0)) AND C V(F0) IS THE FUNCTION VALUE FROM THE PREVIOUS ITERA- C TION), THE RELATIVE FUNCTION REDUCTION PREDICTED FOR THE C STEP JUST TAKEN (I.E., PRELDF = V(PREDUC) / F01, WHERE C V(PREDUC) IS DESCRIBED BELOW), THE SCALED RELATIVE CHANGE C IN X (SEE V(RELDX) BELOW), THE STEP PARAMETER FOR THE C STEP JUST TAKEN (STPPAR = 0 MEANS A FULL NEWTON STEP, C BETWEEN 0 AND 1 MEANS A RELAXED NEWTON STEP, BETWEEN 1 C AND 2 MEANS A DOUBLE DOGLEG STEP, GREATER THAN 2 MEANS C A SCALED DOWN CAUCHY STEP -- SEE SUBROUTINE DBLDOG), THE C 2-NORM OF THE SCALE VECTOR D TIMES THE STEP JUST TAKEN C (SEE V(DSTNRM) BELOW), AND NPRELDF, I.E., C V(NREDUC)/F01, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH C STPPAR = 0). IF NPRELDF IS NEGATIVE, THEN IT IS THE C NEGATIVE OF THE RELATIVE FUNCTION REDUCTION PREDICTED C FOR A STEP COMPUTED WITH STEP BOUND V(LMAXS) FOR USE IN C TESTING FOR SINGULAR CONVERGENCE. C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF LENGTH 50 C ARE PRINTED, INCLUDING ONLY THE FIRST 6 ITEMS LISTED C ABOVE (THROUGH RELDX). C DEFAULT = 1. C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A C FRESH START OR ANY CHANGED V VALUES ON A RESTART. C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING. C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS). C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS C WELL AS THE GRADIENT AND THE SCALE VECTOR D). C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN- C ING. THESE CONSIST OF THE FUNCTION VALUE, THE SCALED C RELATIVE CHANGE IN X CAUSED BY THE MOST RECENT STEP (SEE C V(RELDX) BELOW), THE NUMBER OF FUNCTION AND GRADIENT C EVALUATIONS (CALLS ON CALCF AND CALCG), AND THE RELATIVE C FUNCTION REDUCTIONS PREDICTED FOR THE LAST STEP TAKEN AND C FOR A NEWTON STEP (OR PERHAPS A STEP BOUNDED BY V(LMAXS) C -- SEE THE DESCRIPTIONS OF PRELDF AND NPRELDF UNDER C IV(OUTLEV) ABOVE). C IV(STATPR) = 0 MEANS SKIP THIS PRINTING. C IV(STATPR) = -1 MEANS SKIP THIS PRINTING AS WELL AS THAT C OF THE ONE-LINE TERMINATION REASON MESSAGE. DEFAULT = 1. C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS C PRINTING. DEFAULT = 1. C C *** (SELECTED) IV OUTPUT VALUES *** C C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE.... C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE (SEE C V(RELDX)) BETWEEN THE CURRENT PARAMETER VECTOR X AND C A LOCALLY OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT C MOST V(XCTOL). C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER- C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO- C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL). C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD). C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE. C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A C STEP OF LENGTH AT MOST V(LMAXS) IS UNLIKELY TO YIELD C A RELATIVE FUNCTION DECREASE OF MORE THAN V(SCTOL). C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG- C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL), C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X. C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON- C VERGENCE (SEE IV(MXFCAL)). C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE C (SEE IV(MXITER)). C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT). SEE THE C USAGE NOTES BELOW. C 14 = STORAGE HAS BEEN ALLOCATED (AFTER A CALL WITH C IV(1) = 13). C 17 = RESTART ATTEMPTED WITH N CHANGED. C 18 = D HAS A NEGATIVE COMPONENT AND IV(DTYPE) .LE. 0. C 19...43 = V(IV(1)) IS OUT OF RANGE. C 63 = F(X) CANNOT BE COMPUTED AT THE INITIAL X. C 64 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT C OCCUR). C 65 = THE GRADIENT COULD NOT BE COMPUTED AT X (SEE CALCG C ABOVE). C 67 = BAD FIRST PARAMETER TO DIVSET. C 80 = IV(1) WAS OUT OF RANGE. C 81 = N IS NOT POSITIVE. C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C GRADIENT VECTOR (THE ONE CORRESPONDING TO X). C IV(LASTIV)... IV(44) IS THE LEAST ACCEPTABLE VALUE OF LIV. (IT IS C ONLY SET IF LIV IS AT LEAST 44.) C IV(LASTV).... IV(45) IS THE LEAST ACCEPTABLE VALUE OF LV. (IT IS C ONLY SET IF LIV IS LARGE ENOUGH, AT LEAST IV(LASTIV).) C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS). C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON C CALCG). C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED. C C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE DIVSET) *** C C V(BIAS)..... V(43) IS THE BIAS PARAMETER USED IN SUBROUTINE DBLDOG -- C SEE THAT SUBROUTINE FOR DETAILS. DEFAULT = 0.8. C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. C IF DMNG FINDS A POINT WHERE THE FUNCTION VALUE IS LESS C THAN V(AFCTOL) IN ABSOLUTE VALUE, AND IF DMNG DOES NOT C RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS WITH C IV(1) = 6. THIS TEST CAN BE TURNED OFF BY SETTING C V(AFCTOL) TO ZERO. DEFAULT = MAX(10**-20, MACHEP**2), C WHERE MACHEP IS THE UNIT ROUNDOFF. C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE C VECTOR D IS INITIALIZED. DEFAULT = -1. C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE C VERY FIRST STEP THAT DMNG ATTEMPTS. THIS PARAMETER CAN C MARKEDLY AFFECT THE PERFORMANCE OF DMNG. C V(LMAXS).... V(36) IS USED IN TESTING FOR SINGULAR CONVERGENCE -- IF C THE FUNCTION REDUCTION PREDICTED FOR A STEP OF LENGTH C BOUNDED BY V(LMAXS) IS AT MOST V(SCTOL) * ABS(F0), WHERE C F0 IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION, AND IF DMNG DOES NOT RETURN WITH IV(1) = 3, C 4, 5, OR 6, THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 1. C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE. C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) C AT THE START OF THE CURRENT ITERATION, WHERE F0 IS THE C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT- C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION C DECREASE, THEN DMNG RETURNS WITH IV(1) = 4 (OR 5). C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS C THE UNIT ROUNDOFF. C V(SCTOL).... V(37) IS THE SINGULAR CONVERGENCE TOLERANCE -- SEE THE C DESCRIPTION OF V(LMAXS) ABOVE. C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE. C THIS IS DONE IF THE ACTUAL FUNCTION DECREASE FROM THE C CURRENT STEP IS NO MORE THAN V(TUNER1) TIMES ITS PREDICT- C ED VALUE. DEFAULT = 0.1. C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL) C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC- C TION DECREASE, THEN DMNG RETURNS WITH IV(1) = 3 (OR 5). C (SEE THE DESCRIPTION OF V(RELDX) BELOW.) C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF. C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT- C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL), C AND IF DMNG DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(*)........DIVSET SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE C SECTION 17 OF VERSION 2.2 OF THE NL2SOL USAGE SUMMARY C (I.E., THE APPENDIX TO REF. 1) FOR DETAILS ON V(I), C I = DECFAC, INCFAC, PHMNFC, PHMXFC, RDFCMN, RDFCMX, C TUNER2, TUNER3, TUNER4, TUNER5. C C *** (SELECTED) V OUTPUT VALUES *** C C V(DGNORM)... V(1) IS THE 2-NORM OF (DIAG(D)**-1)*G, WHERE G IS THE C MOST RECENTLY COMPUTED GRADIENT. C V(DSTNRM)... V(2) IS THE 2-NORM OF DIAG(D)*STEP, WHERE STEP IS THE C CURRENT STEP. C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE. C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION. C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC- C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E., C STEP = -H**-1 * G, WHERE G IS THE CURRENT GRADIENT AND C H IS THE CURRENT HESSIAN APPROXIMATION). C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH C A STEP BOUND OF V(LMAXS) FOR USE IN TESTING FOR SINGULAR C CONVERGENCE. C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION C CONVERGENCE. C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE C CURRENT STEP, COMPUTED AS C MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P), C WHERE X = X0 + STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C THIS ROUTINE USES A HESSIAN APPROXIMATION COMPUTED FROM THE C BFGS UPDATE (SEE REF 3). ONLY A CHOLESKY FACTOR OF THE HESSIAN C APPROXIMATION IS STORED, AND THIS IS UPDATED USING IDEAS FROM C REF. 4. STEPS ARE COMPUTED BY THE DOUBLE DOGLEG SCHEME DESCRIBED C IN REF. 2. THE STEPS ARE ASSESSED AS IN REF. 1. C C *** USAGE NOTES *** C C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART, C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT- C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DIVSET). C THOSE WHO DO NOT WISH TO WRITE A CALCG WHICH COMPUTES THE C GRADIENT ANALYTICALLY SHOULD CALL DMNF RATHER THAN DMNG. C DMNF USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE GRADIENT. C THOSE WHO WOULD PREFER TO PROVIDE F AND G (THE FUNCTION AND C GRADIENT) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU- C TINES CALCF AND CALCG MAY CALL ON DRMNG DIRECTLY. SEE THE COM- C MENTS AT THE BEGINNING OF DRMNG. C THOSE WHO USE DMNG INTERACTIVELY MAY WISH TO SUPPLY THEIR C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT C POSSIBLE TO EXTERNALLY INTERRUPT DMNG (WHICH WILL RETURN WITH C IV(1) = 11 IF STOPX RETURNS .TRUE.). C STORAGE FOR G IS ALLOCATED AT THE END OF V. THUS THE CALLER C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCG TO USE C ELEMENTS OF G BEYOND THE FIRST N AS SCRATCH STORAGE. C C *** PORTABILITY NOTES *** C C THE DMNG DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE- C PRECISION VERSIONS OF THE DMNG SOURCE CODE, SO IT SHOULD BE UN- C NECESSARY TO CHANGE PRECISIONS. C ONLY THE FUNCTIONS I7MDCN AND DR7MDC CONTAIN MACHINE-DEPENDENT C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS. C INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED. ON CERTAIN COM- C PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE C DECLARATIONS. SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE C PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+ C IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY C A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72. C THE DMNG SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD C FORTRAN. IT MAY BE CONVERTED TO FORTRAN 77 BY COMMENTING OUT ALL C LINES THAT FALL BETWEEN A LINE HAVING C/6 IN COLUMNS 1-3 AND A C LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING (I.E., REPLACING C BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT FOLLOW THE C/7 C LINE AND PRECEDE A LINE HAVING C/ IN COLUMNS 1-2 AND BLANKS IN C COLUMNS 3-72. THESE CHANGES CONVERT SOME DATA STATEMENTS INTO C PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM REAL TO C CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE THESE C VARIABLES USE CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD C OF HOLLERITH CONSTANTS. (SUCH VARIABLES AND DATA STATEMENTS C APPEAR ONLY IN MODULES DITSUM AND DPARCK. PARAMETER STATEMENTS C APPEAR NEARLY EVERYWHERE.) THESE CHANGES ALSO ADD SAVE STATE- C MENTS FOR VARIABLES GIVEN MACHINE-DEPENDENT CONSTANTS BY DR7MDC. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), ALGORITHM 573 -- C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. C MATH. SOFTWARE 7, PP. 369-383. C C 2. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI- C MIZATION ALGORITHMS WHICH USE FUNCTION AND GRADIENT C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482. C C 3. DENNIS, J.E., AND MORE, J.J. (1977), QUASI-NEWTON METHODS, MOTIVA- C TION AND THEORY, SIAM REV. 19, PP. 46-89. C C 4. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON- C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811. C C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SUMMER 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, C AND MCS-7906671. C. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL DIVSET, DRMNG C C DIVSET... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C DRMNG... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT DMNG ALGO- C RITHM. C INTEGER G1, IV1, NF DOUBLE PRECISION F C C *** SUBSCRIPTS FOR IV *** C INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + N IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) C 20 CALL DRMNG(D, F, V(G1), IV, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 50 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 50 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(NEXTV) = IV(G) + N IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF DMNG FOLLOWS *** END SUBROUTINE DMNGB(N, D, X, B, CALCF, CALCG, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING *** C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE *** C INTEGER N, LIV, LV C/6S C INTEGER IV(LIV), UIPARM(1) C DOUBLE PRECISION D(N), X(N), B(2,N), V(LV), URPARM(1) C/7S INTEGER IV(LIV), UIPARM(*) DOUBLE PRECISION D(N), X(N), B(2,N), V(LV), URPARM(*) C/ C DIMENSION IV(59 + N), V(71 + N*(N+21)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, CALCG, UFPARM C C *** DISCUSSION *** C C THIS ROUTINE IS LIKE DMNG, EXCEPT FOR THE EXTRA PARAMETER B, C AN ARRAY OF LOWER AND UPPER BOUNDS ON X... DMNGB ENFORCES THE C CONSTRAINTS THAT B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)N. C (INSTEAD OF CALLING DRMNG, DMNGB CALLS DRMNGB.) C. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL DIVSET, DRMNGB C C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C DRMNGB... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT DMNG ALGO- C RITHM. C INTEGER G1, IV1, NF DOUBLE PRECISION F C C *** SUBSCRIPTS FOR IV *** C INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N CALL DRMNGB(B, D, F, V, IV, LIV, LV, N, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(NEXTV) = IV(G) + N IF (IV1 .EQ. 13) GO TO 999 C 10 G1 = IV(G) C 20 CALL DRMNGB(B, D, F, V(G1), IV, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 999 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C *** LAST CARD OF DMNGB FOLLOWS *** END SUBROUTINE DMNH(N, D, X, CALCF, CALCGH, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING *** C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. *** C INTEGER LIV, LV, N INTEGER IV(LIV), UIPARM(1) DOUBLE PRECISION D(N), X(N), V(LV), URPARM(1) C DIMENSION V(78 + N*(N+12)), UIPARM(*), URPARM(*) EXTERNAL CALCF, CALCGH, UFPARM C C------------------------------ DISCUSSION --------------------------- C C THIS ROUTINE IS LIKE DMNG, EXCEPT THAT THE SUBROUTINE PARA- C METER CALCG OF DMNG (WHICH COMPUTES THE GRADIENT OF THE OBJEC- C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH, C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE) C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS... C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM) C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME C AS FOR DMNG, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START- C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... C THE VALUE PRINTED (BY DITSUM) IN THE COLUMN LABELLED STPPAR C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP. C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN C IS NOT POSITIVE DEFINITE. C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT... C C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE C INITIALIZED BY CALLING DMNH WITH IV(1) = 13.) C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN. C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0. C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT), DESCRIBED IN DMNG.) LET C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)), C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), DTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED DTOL IN V STARTING AT V(IV(DTOL)). C DEFAULT = 10**-6. C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0. C C *** REFERENCE *** C C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL DIVSET, DRMNH C C DIVSET... PROVIDES DEFAULT INPUT VALUES FOR IV AND V. C DRMNH... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNH ALGORITHM. C INTEGER G1, H1, IV1, LH, NF DOUBLE PRECISION F C C *** SUBSCRIPTS FOR IV *** C INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/, C 1 VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2, 1 VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = N * (N + 1) / 2 IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13) 1 IV(VNEED) = IV(VNEED) + N*(N+3)/2 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 H1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) H1 = IV(H) C 20 CALL DRMNH(D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 50 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 50 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(H) = IV(G) + N IV(NEXTV) = IV(H) + N*(N+1)/2 IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF DMNH FOLLOWS *** END SUBROUTINE DMNHB(N, D, X, B, CALCF, CALCGH, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING *** C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. *** C INTEGER LIV, LV, N C/6S C INTEGER IV(LIV), UIPARM(1) C DOUBLE PRECISION B(2,N), D(N), X(N), V(LV), URPARM(1) C/7S INTEGER IV(LIV), UIPARM(*) DOUBLE PRECISION B(2,N), D(N), X(N), V(LV), URPARM(*) C/ C DIMENSION IV(59 + 3*N), V(78 + N*(N+15)) EXTERNAL CALCF, CALCGH, UFPARM C C------------------------------ DISCUSSION --------------------------- C C THIS ROUTINE IS LIKE DMNGB, EXCEPT THAT THE SUBROUTINE PARA- C METER CALCG OF DMNGB (WHICH COMPUTES THE GRADIENT OF THE OBJEC- C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH, C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE) C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS... C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM) C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME C AS FOR DMNGB, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START- C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... C THE VALUE PRINTED (BY DITSUM) IN THE COLUMN LABELLED STPPAR C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP. C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN C IS NOT POSITIVE DEFINITE. C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT... C C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE C INITIALIZED BY CALLING DMNHB WITH IV(1) = 13.) C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN. C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0. C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT), DESCRIBED IN DMNG.) LET C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)), C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), DTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED DTOL IN V STARTING AT V(IV(DTOL)). C DEFAULT = 10**-6. C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0. C C *** REFERENCE *** C C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER, SPRING 1983). C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL DIVSET, DRMNHB C C DIVSET.... PROVIDES DEFAULT INPUT VALUES FOR IV AND V. C DRMNHB... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNHB ALGORITHM. C INTEGER G1, H1, IV1, LH, NF DOUBLE PRECISION F C C *** SUBSCRIPTS FOR IV *** C INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/, C 1 VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2, 1 VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = N * (N + 1) / 2 IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N*(N+3)/2 CALL DRMNHB(B, D, F, V, V, IV, LH, LIV, LV, N, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(H) = IV(G) + N IV(NEXTV) = IV(H) + N*(N+1)/2 IF (IV1 .EQ. 13) GO TO 999 C 10 G1 = IV(G) H1 = IV(H) C 20 CALL DRMNHB(B, D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 999 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C *** LAST CARD OF DMNHB FOLLOWS *** END SUBROUTINE DN2CVP(IV, LIV, LV, P, V) C C *** PRINT COVARIANCE MATRIX FOR DRN2G *** C INTEGER LIV, LV, P INTEGER IV(LIV) DOUBLE PRECISION V(LV) C C *** LOCAL VARIABLES *** C INTEGER COV1, I, II, I1, J, PU DOUBLE PRECISION T C C *** IV SUBSCRIPTS *** C INTEGER COVMAT, COVPRT, COVREQ, NEEDHD, NFCOV, NGCOV, PRUNIT, 1 RCOND, REGD, STATPR C C/6 C DATA COVMAT/26/, COVPRT/14/, COVREQ/15/, NEEDHD/36/, NFCOV/52/, C 1 NGCOV/53/, PRUNIT/21/, RCOND/53/, REGD/67/, STATPR/23/ C/7 PARAMETER (COVMAT=26, COVPRT=14, COVREQ=15, NEEDHD=36, NFCOV=52, 1 NGCOV=53, PRUNIT=21, RCOND=53, REGD=67, STATPR=23) C/ C *** BODY *** C IF (IV(1) .GT. 8) GO TO 999 PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (IV(STATPR) .EQ. 0) GO TO 30 IF (IV(NFCOV) .GT. 0) WRITE(PU,10) IV(NFCOV) 10 FORMAT(/1X,I4,50H EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOST 1ICS.) IF (IV(NGCOV) .GT. 0) WRITE(PU,20) IV(NGCOV) 20 FORMAT(1X,I4,50H EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTI 1CS.) C 30 IF (IV(COVPRT) .LE. 0) GO TO 999 COV1 = IV(COVMAT) IF (IV(REGD) .LE. 0 .AND. COV1 .LE. 0) GO TO 70 IV(NEEDHD) = 1 T = V(RCOND)**2 IF (IABS(IV(COVREQ)) .GT. 2) GO TO 50 C WRITE(PU,40) T 40 FORMAT(/47H RECIPROCAL CONDITION OF F.D. HESSIAN = AT MOST,D10.2) GO TO 70 C 50 WRITE(PU,60) T 60 FORMAT(/44H RECIPROCAL CONDITION OF (J**T)*J = AT LEAST,D10.2) C 70 IF (MOD(IV(COVPRT),2) .EQ. 0) GO TO 999 IV(NEEDHD) = 1 IF (COV1) 80,110,130 80 IF (-1 .EQ. COV1) WRITE(PU,90) 90 FORMAT(/43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,100) 100 FORMAT(/52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 110 WRITE(PU,120) 120 FORMAT(/45H ++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 999 C 130 I = IABS(IV(COVREQ)) IF (I .LE. 1) WRITE(PU,140) 140 FORMAT(/48H COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/ 1 23H WHERE H = F.D. HESSIAN/) IF (I .EQ. 2) WRITE(PU,150) 150 FORMAT(/56H COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIA 1N/) IF (I .GT. 2) WRITE(PU,160) 160 FORMAT(/30H COVARIANCE = SCALE * J**T * J/) II = COV1 - 1 DO 170 I = 1, P I1 = II + 1 II = II + I WRITE(PU,180) I, (V(J), J = I1, II) 170 CONTINUE 180 FORMAT(4H ROW,I3,2X,5D12.3/(9X,5D12.3)) C 999 RETURN C *** LAST CARD OF DN2CVP FOLLOWS *** END SUBROUTINE DN2F(N, P, X, CALCR, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY.. C *** THIS AMOUNTS TO DN2G WITHOUT THE SUBROUTINE PARAMETER CALCJ. C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UIPARM(1) C DOUBLE PRECISION X(P), V(LV), URPARM(1) C/7 INTEGER IV(LIV), UIPARM(*) DOUBLE PRECISION X(P), V(LV), URPARM(*) C/ EXTERNAL CALCR, UFPARM C C----------------------------- DISCUSSION ---------------------------- C C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO CALL C DRN2G. C THE PARAMETERS FOR DN2F ARE THE SAME AS THOSE FOR DN2G C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, DN2F COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. DN2F USES FUNCTION VALUES ONLY WHEN COMPUT- C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS C THAT DN2G MAY USE). TO DO SO, DN2F SETS IV(COVREQ) TO MINUS C ITS ABSOLUTE VALUE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC). C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD. C C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. C C *** REFERENCE *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRN2G, DN2RDP, DV7SCP C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRN2G... CARRIES OUT OPTIMIZATION ITERATIONS. C DN2RDP... PRINTS REGRESSION DIAGNOSTICS. C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN DOUBLE PRECISION H, H0, HLIM, NEGPT5, ONE, XK, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, REGD, REGD0, TOOBIG, VNEED C/6 C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/, C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/, C 2 R/61/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, REGD=67, REGD0=82, TOOBIG=2, VNEED=4) C/ DATA HLIM/0.1D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL DRN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RN = R1 + N - 1 RD1 = IV(REGD0) C 20 CALL DRN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 100 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL DV7SCP(P, V(D1), ONE) C J1K = DR1 DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 DO 90 K = 1, P XK = X(K) H = V(DLTFDJ) * DMAX1(DABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 60 X(K) = XK + H NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM) NG = NG + 1 IF (NF .GT. 0) GO TO 70 H = NEGPT5 * H IF (DABS(H/H0) .GE. HLIM) GO TO 60 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 70 X(K) = XK IV(NGCALL) = NG DO 80 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 80 CONTINUE 90 CONTINUE GO TO 20 C 100 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 CALL DN2RDP(IV, LIV, LV, N, V(RD1), V) C 999 RETURN C C *** LAST LINE OF DN2F FOLLOWS *** END SUBROUTINE DN2FB(N, P, X, B, CALCR, IV, LIV, LV, V, UI, UR, UF) C C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY.. C *** THIS AMOUNTS TO DN2G WITHOUT THE SUBROUTINE PARAMETER CALCJ. C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C DOUBLE PRECISION X(P), B(2,P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) DOUBLE PRECISION X(P), B(2,P), V(LV), UR(*) C/ EXTERNAL CALCR, UF C C----------------------------- DISCUSSION ---------------------------- C C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO HANDLE C SIMPLE BOUNDS ON THE VARIABLES... C B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P. C THE PARAMETERS FOR DN2FB ARE THE SAME AS THOSE FOR DN2GB C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, DN2FB COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. DN2FB DOES NOT COMPUTE A COVARIANCE MATRIX. C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD. C C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. C C *** REFERENCE *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRN2GB, DV7SCP C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRN2GB... CARRIES OUT OPTIMIZATION ITERATIONS. C DN2RDP... PRINTS REGRESSION DIAGNOSTICS. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN DOUBLE PRECISION H, H0, HLIM, NEGPT5, ONE, T, XK, XK1, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, REGD0, TOOBIG, VNEED C/6 C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/, C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/, C 2 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, REGD0=82, TOOBIG=2, VNEED=4) C/ DATA HLIM/0.1D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV(COVREQ) = 0 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL DRN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RN = R1 + N - 1 RD1 = IV(REGD0) C 20 CALL DRN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL DV7SCP(P, V(D1), ONE) C J1K = DR1 DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 DO 120 K = 1, P IF (B(1,K) .GE. B(2,K)) GO TO 110 XK = X(K) H = V(DLTFDJ) * DMAX1(DABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 T = NEGPT5 XK1 = XK + H IF (XK - H .GE. B(1,K)) GO TO 60 T = -T IF (XK1 .GT. B(2,K)) GO TO 80 60 IF (XK1 .LE. B(2,K)) GO TO 70 T = -T H = -H XK1 = XK + H IF (XK1 .LT. B(1,K)) GO TO 80 70 X(K) = XK1 NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UI, UR, UF) NG = NG + 1 IF (NF .GT. 0) GO TO 90 H = T * H XK1 = XK + H IF (DABS(H/H0) .GE. HLIM) GO TO 70 80 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 90 X(K) = XK IV(NGCALL) = NG DO 100 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 100 CONTINUE GO TO 120 C *** SUPPLY A ZERO DERIVATIVE FOR CONSTANT COMPONENTS... 110 CALL DV7SCP(N, V(J1K), ZERO) J1K = J1K + N 120 CONTINUE GO TO 20 C 999 RETURN C C *** LAST CARD OF DN2FB FOLLOWS *** END SUBROUTINE DN2G(N, P, X, CALCR, CALCJ, IV, LIV, LV, V, 1 UI, UR, UF) C C *** VERSION OF NL2SOL THAT CALLS DRN2G *** C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C DOUBLE PRECISION X(P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) DOUBLE PRECISION X(P), V(LV), UR(*) C/ EXTERNAL CALCR, CALCJ, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST C PARTIALS OF THE RESIDUAL VECTOR. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C UI...... PASSED UNCHANGED TO CALCR AND CALCJ. C UR...... PASSED UNCHANGED TO CALCR AND CALCJ. C UF...... PASSED UNCHANGED TO CALCR AND CALCJ. C C C *** DISCUSSION *** C C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383 C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, C D.M. GAY, AND R.E. WELSCH). C C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82+P. IF NOT, C THEN DN2G RETURNS WITH IV(1) = 15. WHEN DN2G RETURNS, THE C MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN IV(LASTIV) = IV(44), C (PROVIDED THAT LIV .GE. 44). C C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS C LV0 = 105 + P*(N + 2*P + 17) + 2*N. IF LV IS SMALLER THAN THIS, C THEN DN2G RETURNS WITH IV(1) = 16. WHEN DN2G RETURNS, THE C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45) C (PROVIDED LIV .GE. 45). C C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL. C C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION. C C *** DEFAULT VALUES *** C C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE DIVSET, RATHER THAN C DFAULT. THE CALLING SEQUENCE IS... C CALL DIVSET(1, IV, LIV, LV, V) C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE C ENOUGH FOR DIVSET, THEN DIVSET SETS IV(1) TO 12. OTHERWISE IT C SETS IV(1) TO 15 OR 16. CALLING DN2G WITH IV(1) = 0 CAUSES ALL C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V. C IF YOU FIRST CALL DIVSET, THEN SET IV(1) TO 13 AND CALL DN2G, C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR, C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV C ARE LARGE ENOUGH. IF SO, THEN DN2G RETURNS WITH IV(1) = 14. C WHEN CALLED WITH IV(1) = 14, DN2G ASSUMES THAT STORAGE HAS C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM. C C *** SCALE VECTOR *** C C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET C BEFORE THE ALGORITHM IS STARTED. C C *** REGRESSION DIAGNOSTICS *** C C IF IV(RDREQ) SO DICTATES, THEN ESTIMATES ARE COMPUTED OF THE C INFLUENCE EACH RESIDUAL COMPONENT HAS ON THE FINAL PARAMETER C ESTIMATE X. THE GENERAL IDEA IS THAT ONE MAY WISH TO EXAMINE C RESIDUAL COMPONENTS (AND THE DATA BEHIND THEM) FOR WHICH THE C INFLUENCE ESTIMATE IS SIGNIFICANTLY LARGER THAN MOST OF THE OTHER C INFLUENCE ESTIMATES. THESE ESTIMATES, HEREAFTER CALLED C REGRESSION DIAGNOSTICS, ARE ONLY COMPUTED IF IV(RDREQ) = 2 OR 3. C IN THIS CASE, FOR I = 1(1)N, C SQRT( G(I)**T * H(I)**-1 * G(I) ) C IS COMPUTED AND STORED IN V, STARTING AT V(IV(REGD)), WHERE C RDREQ = 57 AND REGD = 67. HERE G(I) STANDS FOR THE GRADIENT C RESULTING WHEN THE I-TH OBSERVATION IS DELETED AND H(I) STANDS C FOR AN APPROXIMATION TO THE CORRESPONDING HESSIAN AT X, THE SOLU- C TION CORRESPONDING TO ALL OBSERVATIONS. (THIS APPROXIMATION IS C OBTAINED BY SUBTRACTING THE FIRST-ORDER CONTRIBUTION OF THE I-TH C OBSERVATION TO THE HESSIAN FROM A FINITE-DIFFERENCE HESSIAN C APPROXIMATION. IF H IS INDEFINITE, THEN IV(REGD) IS SET TO -1. C IF H(I) IS INDEFINITE, THEN -1 IS RETURNED AS THE DIAGNOSTIC FOR C OBSERVATION I. IF NO DIAGNOSTICS ARE COMPUTED, PERHAPS BECAUSE C OF A FAILURE TO CONVERGE, THEN IV(REGD) = 0 IS RETURNED.) C PRINTING OF THE REGRESSION DIAGNOSTICS IS CONTROLLED BY C IV(COVPRT) = IV(14)... IF IV(COVPRT) = 3, THEN BOTH THE C COVARIANCE MATRIX AND THE REGRESSION DIAGNOSTICS ARE PRINTED. C IV(COVPRT) = 2 CAUSES ONLY THE REGRESSION DIAGNOSTICS TO BE C PRINTED, IV(COVPRT) = 1 CAUSES ONLY THE COVARIANCE MATRIX TO BE C PRINTED, AND IV(COVPRT) = 0 CAUSES NEITHER TO BE PRINTED. C C RDREQ = 57 AND REGD = 67. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRN2G, DN2RDP C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRN2G... CARRIES OUT OPTIMIZATION ITERATIONS. C DN2RDP... PRINTS REGRESSION DIAGNOSTICS. C C *** NO INTRINSIC FUNCTIONS *** C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED C/6 C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/, C 1 REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL DRN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL DRN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 60 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UI, UR, UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED C *** AND PRINT IT IF SO REQUESTED... C 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 CALL DN2RDP(IV, LIV, LV, N, V(RD1), V) C 999 RETURN C C *** LAST LINE OF DN2G FOLLOWS *** END SUBROUTINE DN2GB(N, P, X, B, CALCR, CALCJ, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** VERSION OF NL2SOL THAT HANDLES SIMPLE BOUNDS ON X *** C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UIPARM(1) C DOUBLE PRECISION X(P), B(2,P), V(LV), URPARM(1) C/7 INTEGER IV(LIV), UIPARM(*) DOUBLE PRECISION X(P), B(2,P), V(LV), URPARM(*) C/ EXTERNAL CALCR, CALCJ, UFPARM C C *** DISCUSSION *** C C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383 C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, C D.M. GAY, AND R.E. WELSCH). C C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82 + 4*P. C IF NOT, THEN DN2GB RETURNS WITH IV(1) = 15. WHEN DN2GB C RETURNS, THE MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN C IV(LASTIV) = IV(44), (PROVIDED THAT LIV .GE. 44). C C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS C LV0 = 105 + P*(N + 2*P + 21) + 2*N. IF LV IS SMALLER THAN THIS, C THEN DN2GB RETURNS WITH IV(1) = 16. WHEN DN2GB RETURNS, THE C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45) C (PROVIDED LIV .GE. 45). C C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL. C C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION. C C *** BOUNDS *** C C THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P, ARE ENFORCED. C C *** DEFAULT VALUES *** C C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE DIVSET, RATHER THAN C DFAULT. THE CALLING SEQUENCE IS... C CALL DIVSET(1, IV, LIV, LV, V) C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE C ENOUGH FOR DIVSET, THEN DIVSET SETS IV(1) TO 12. OTHERWISE IT C SETS IV(1) TO 15 OR 16. CALLING DN2GB WITH IV(1) = 0 CAUSES ALL C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V. C IF YOU FIRST CALL DIVSET, THEN SET IV(1) TO 13 AND CALL DN2GB, C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR, C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV C ARE LARGE ENOUGH. IF SO, THEN DN2GB RETURNS WITH IV(1) = 14. C WHEN CALLED WITH IV(1) = 14, DN2GB ASSUMES THAT STORAGE HAS C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM. C C *** SCALE VECTOR *** C C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET C BEFORE THE ALGORITHM IS STARTED. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRN2GB C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRN2GB... CARRIES OUT OPTIMIZATION ITERATIONS. C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD0, TOOBIG, VNEED C/6 C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/, C 1 REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD0=82, TOOBIG=2, VNEED=4) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL DRN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL DRN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C C *** LAST CARD OF DN2GB FOLLOWS *** END SUBROUTINE DN2LRD(DR, IV, L, LH, LIV, LV, ND, NN, P, R, RD, V) C C *** COMPUTE REGRESSION DIAGNOSTIC AND DEFAULT COVARIANCE MATRIX FOR C DRN2G *** C C *** PARAMETERS *** C INTEGER LH, LIV, LV, ND, NN, P INTEGER IV(LIV) DOUBLE PRECISION DR(ND,P), L(LH), R(NN), RD(NN), V(LV) C C *** CODED BY DAVID M. GAY (WINTER 1982, FALL 1983) *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR, DL7ITV, DL7IVM,DO7PRD, DV7SCP C C *** LOCAL VARIABLES *** C INTEGER COV, I, J, M, STEP1 DOUBLE PRECISION A, FF, S, T C C *** CONSTANTS *** C DOUBLE PRECISION NEGONE, ONE, ONEV(1), ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C C *** IV AND V SUBSCRIPTS *** C INTEGER F, H, MODE, RDREQ, STEP C/6 C DATA F/10/, H/56/, MODE/35/, RDREQ/57/, STEP/40/ C/7 PARAMETER (F=10, H=56, MODE=35, RDREQ=57, STEP=40) C/ C/6 C DATA NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/ C/7 PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0) C/ DATA ONEV(1)/1.D+0/ C C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++ C STEP1 = IV(STEP) I = IV(RDREQ) IF (I .LE. 0) GO TO 999 IF (MOD(I,4) .LT. 2) GO TO 30 FF = ONE IF (V(F) .NE. ZERO) FF = ONE / DSQRT(DABS(V(F))) CALL DV7SCP(NN, RD, NEGONE) DO 20 I = 1, NN A = R(I)**2 M = STEP1 DO 10 J = 1, P V(M) = DR(I,J) M = M + 1 10 CONTINUE CALL DL7IVM(P, V(STEP1), L, V(STEP1)) S = DD7TPR(P, V(STEP1), V(STEP1)) T = ONE - S IF (T .LE. ZERO) GO TO 20 A = A * S / T RD(I) = DSQRT(A) * FF 20 CONTINUE C 30 IF (IV(MODE) - P .LT. 2) GO TO 999 C C *** COMPUTE DEFAULT COVARIANCE MATRIX *** C COV = IABS(IV(H)) DO 50 I = 1, NN M = STEP1 DO 40 J = 1, P V(M) = DR(I,J) M = M + 1 40 CONTINUE CALL DL7IVM(P, V(STEP1), L, V(STEP1)) CALL DL7ITV(P, V(STEP1), L, V(STEP1)) CALL DO7PRD(1, LH, P, V(COV), ONEV, V(STEP1), V(STEP1)) 50 CONTINUE C 999 RETURN C *** LAST LINE OF DN2LRD FOLLOWS *** END SUBROUTINE DN2P(N, ND, P, X, CALCR, CALCJ, IV, LIV, LV, V, 1 UI, UR, UF) C C *** VERSION OF NL2SOL THAT CALLS DRN2G AND HAS EXPANDED CALLING C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J C *** (RESIDUALS AND JACOBIAN) IN CHUNKS. C C *** PARAMETERS *** C INTEGER N, ND, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C DOUBLE PRECISION X(P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) DOUBLE PRECISION X(P), V(LV), UR(*) C/ EXTERNAL CALCR, CALCJ, UF C C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL C ON CALCR. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST C PARTIALS OF THE RESIDUAL VECTOR. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C UI...... PASSED UNCHANGED TO CALCR AND CALCJ. C UR...... PASSED UNCHANGED TO CALCR AND CALCJ. C UF...... PASSED UNCHANGED TO CALCR AND CALCJ. C C C *** DISCUSSION *** C C THIS ROUTINE IS SIMILAR TO DN2G (WHICH SEE), EXCEPT THAT THE C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS. C C FOR CALCR, THE CALLING SEQUENCE IS... C C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF) C C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED C BY NL2SOL OR DN2G. C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT C CHANGE ND1 OR N1 (BUT MAY CHANGE N2). C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT C CALCR SHOULD SUPPLY ON ONE CALL. C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD C SUPPLY ON THIS CALL. C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2 C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS C R(1), R(2), ..., R(N2-N1+1). C C FOR CALCJ, THE CALLING SEQUENCE IS... C C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF) C C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED, C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.) C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2 C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K). C C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DN2RDP, DRN2G C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DN2RDP... PRINTS REGRESSION DIAGNOSTICS. C DRN2G... CARRIES OUT OPTIMIZATION ITERATIONS. C C *** LOCAL VARIABLES *** C LOGICAL ONERD INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD0, RD1, X01 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R, RDREQ, REGD, 1 REGD0, TOOBIG, VNEED, X0 C/6 C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/, C 1 R/61/, RDREQ/57/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/, C 2 X0/43/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7, 1 R=61, RDREQ=57, REGD=67, REGD0=82, TOOBIG=2, VNEED=4, 2 X0=43) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) ND1 = MIN0(ND, N) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = IV(VNEED) + P + ND1*(P+1) ONERD = IV(RDREQ) .GE. 2 .OR. ND .GE. N IF (ONERD) I = I + N IF (IV(1) .EQ. 13) IV(VNEED) = I CALL DRN2G(V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P I = IV(R) + ND1 IV(REGD0) = I IF (ONERD) I = I + N IV(J) = I IV(NEXTV) = I + ND1*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) RD0 = RD1 - 1 C 20 CALL DRN2G(V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P, V(R1), 1 V(RD1), V, X) IV1 = IV(1) IF (IV1-2) 40, 30, 80 30 IF (ND .GE. N) GO TO 70 C C *** FIRST COMPUTE RELEVANT PORTION OF R *** C 40 NF = IV(NFCALL) IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL) CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 50 IV(TOOBIG) = 1 GO TO 20 50 I = IV1 + 4 GO TO (70, 60, 70, 20, 20, 70), I 60 X01 = IV(X0) CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI, 1 UR, UF) IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1 GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 RD1 = RD0 + N1 GO TO 20 C 80 RD1 = RD0 + 1 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 IF (IV(1) .LE. 8) CALL DN2RDP(IV, LIV, LV, N, V(RD1), V) C 999 RETURN C C *** LAST LINE OF DN2P FOLLOWS *** END SUBROUTINE DN2PB(N, ND, P, X, B, CALCR, CALCJ, IV, LIV, LV, V, 1 UI, UR, UF) C C *** SIMPLY BOUNDED VERSION OF NL2SOL THAT HAS EXPANDED CALLING C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J C *** (RESIDUALS AND JACOBIAN) IN CHUNKS. C C *** PARAMETERS *** C INTEGER N, ND, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C DOUBLE PRECISION B(2,P), X(P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) DOUBLE PRECISION B(2,P), X(P), V(LV), UR(*) C/ EXTERNAL CALCR, CALCJ, UF C C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL C ON CALCR. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST C PARTIALS OF THE RESIDUAL VECTOR. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C UI...... PASSED UNCHANGED TO CALCR AND CALCJ. C UR...... PASSED UNCHANGED TO CALCR AND CALCJ. C UF...... PASSED UNCHANGED TO CALCR AND CALCJ. C C C *** DISCUSSION *** C C THIS ROUTINE IS SIMILAR TO DN2G (WHICH SEE), EXCEPT THAT THE C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS. C C FOR CALCR, THE CALLING SEQUENCE IS... C C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF) C C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED C BY NL2SOL OR DN2G. C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT C CHANGE ND1 OR N1 (BUT MAY CHANGE N2). C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT C CALCR SHOULD SUPPLY ON ONE CALL. C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD C SUPPLY ON THIS CALL. C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2 C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS C R(1), R(2), ..., R(N2-N1+1). C C FOR CALCJ, THE CALLING SEQUENCE IS... C C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF) C C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED, C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.) C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2 C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K). C C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRN2GB C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRN2GB... CARRIES OUT OPTIMIZATION ITERATIONS. C C *** LOCAL VARIABLES *** C LOGICAL ONERD INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD1, X01 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R, 1 REGD0, TOOBIG, VNEED, X0 C/6 C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/, C 1 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/, X0/43/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7, 1 R=61, REGD0=82, TOOBIG=2, VNEED=4, X0=43) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) ND1 = MIN0(ND, N) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = IV(VNEED) + P + ND1*(P+1) ONERD = ND .GE. N IF (ONERD) I = I + N IF (IV(1) .EQ. 13) IV(VNEED) = I CALL DRN2GB(B, V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P I = IV(R) + ND1 IV(REGD0) = I IF (ONERD) I = I + N IV(J) = I IV(NEXTV) = I + ND1*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL DRN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P, 1 V(R1), V(RD1), V, X) IV1 = IV(1) IF (IV1-2) 40, 30, 999 30 IF (ND .GE. N) GO TO 70 C C *** FIRST COMPUTE RELEVANT PORTION OF R *** C 40 NF = IV(NFCALL) IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL) CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 50 IV(TOOBIG) = 1 GO TO 20 50 I = IV1 + 4 GO TO (70, 60, 70, 20, 20, 70), I 60 X01 = IV(X0) CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI, 1 UR, UF) IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1 GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C C *** LAST LINE OF DN2PB FOLLOWS *** END SUBROUTINE DN2RDP(IV, LIV, LV, N, RD, V) C C *** PRINT REGRESSION DIAGNOSTICS FOR MLPSL AND NL2S1 *** C INTEGER LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION RD(N), V(LV) C C *** NOTE -- V IS PASSED FOR POSSIBLE USE BY REVISED VERSIONS OF C *** THIS ROUTINE. C INTEGER PU C C *** IV AND V SUBSCRIPTS *** C INTEGER COVPRT, F, NEEDHD, PRUNIT, REGD C C/6 C DATA COVPRT/14/, F/10/, NEEDHD/36/, PRUNIT/21/, REGD/67/ C/7 PARAMETER (COVPRT=14, F=10, NEEDHD=36, PRUNIT=21, REGD=67) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (IV(COVPRT) .LT. 2) GO TO 999 IF (IV(REGD) .LE. 0) GO TO 999 IV(NEEDHD) = 1 IF (V(F)) 10, 30, 10 10 WRITE(PU,20) RD 20 FORMAT(/70H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I 1) / ABS(F) ).../(6D12.3)) GO TO 999 30 WRITE(PU,40) RD 40 FORMAT(/61H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I 1) ).../(6D12.3)) C 999 RETURN C *** LAST LINE OF DN2RDP FOLLOWS *** END SUBROUTINE DNSF(N, P, L, ALF, C, Y, CALCA, INC, IINC, IV, 1 LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING C *** FINITE-DIFFERENCE DERIVATIVES. C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C DOUBLE PRECISION ALF(P), C(L), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) DOUBLE PRECISION ALF(P), C(L), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, UFPARM C C *** PARAMETERS *** C C N (IN) NUMBER OF OBSERVATIONS. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C C (OUT) LINEAR PARAMETERS (ESTIMATED). C Y (IN) RIGHT-HAND SIDE VECTOR. C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX. C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I C OF A DEPENDS ON ALF(J). C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST C 122 + 2*M + 4*P + 2*L + MAX(L+1,6*P), WHERE M IS C THE NUMBER OF ONES IN INC. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + 2*N*(L+3) + JLEN + L*(L+3)/2 + P*(2*P + 18), C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE LAST C ROW OF INC CONTAINS ONLY ZEROS, THEN LV CAN BE 4*N C LESS THAN JUST DESCRIBED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST, C FOLLOWED BY LINEAR PARAMETERS. C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA. C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA. C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA. C C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DSM, DRNSG,DV2AXY,DV7CPY, DV7SCL C C DIVSET.... PROVIDES DEFAULT IV AND V VALUES. C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES. C DRNSG... CARRIES OUT NL2SOL ALGORITHM. C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C LOGICAL PARTJ INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1, 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1, 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0, 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1 DOUBLE PRECISION DELTA, DI, H, XI DOUBLE PRECISION NEGONE, ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED, 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL, 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/, C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/, C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/, C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/, C 4 VNEED/4/, XSAVE/119/ C/7 PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43, 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111, 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47, 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2, 4 VNEED=4, XSAVE=119) C/ DATA NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C LP1 = L + 1 IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 120 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 50 C C *** FRESH START *** C IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1 C C *** CHECK INC, COUNT ITS NONZEROS C L1 = 0 M = 0 DO 40 I = 1, P M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 80 40 CONTINUE C C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 *** C C *** COMPUTE STORAGE REQUIREMENTS *** C IWALEN = MAX0(LP1, 6*P) INLEN = 2 * M IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3 RSVLEN = 2 * L1 * N L1 = L + L1 IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P C 50 CALL DRNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(XSAVE) = IV(DAMAT) + N*L1 IV(NEXTV) = IV(XSAVE) + P + RSVLEN IV(L1SAV) = L1 IV(MSAVE) = M C C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES C *** (SET UP TO CALL DSM) C IN1 = IV(IN) JN1 = IN1 + M DO 70 K = 1, P DO 60 I = 1, LP1 IF (INC(I,K) .EQ. 0) GO TO 60 IV(IN1) = I IN1 = IN1 + 1 IV(JN1) = K JN1 = JN1 + 1 60 CONTINUE 70 CONTINUE IN1 = IV(IN) JN1 = IN1 + M IWA1 = IN1 + INLEN NGRP1 = IWA1 + IWALEN BWA1 = NGRP1 + P IPNTR1 = BWA1 + P JPNTR1 = IPNTR1 + L + 2 CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I, 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1)) IF (I .EQ. 1) GO TO 90 IV(1) = 69 GO TO 50 80 IV(1) = 66 GO TO 50 C C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES C C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1. C 90 IV(MAXGRP) = NG IV(GPTR) = IN1 + 2*L1 GPTR1 = IV(GPTR) IV(GRP) = GPTR1 + NG + 1 IV(NEXTIV) = IV(GRP) + P GRP1 = IV(GRP) NGRP0 = NGRP1 - 1 NGRP2 = NGRP0 + P DO 110 I = 1, NG IV(GPTR1) = GRP1 GPTR1 = GPTR1 + 1 DO 100 I1 = NGRP1, NGRP2 IF (IV(I1) .NE. I) GO TO 100 IV(GRP1) = I1 - NGRP0 GRP1 = GRP1 + 1 100 CONTINUE 110 CONTINUE IV(GPTR1) = GRP1 IF (IV1 .EQ. 13) GO TO 999 C C *** INITIALIZE POINTERS *** C 120 A1 = IV(AMAT) A0 = A1 - N DA1 = IV(DAMAT) DA0 = DA1 - N IN1 = IV(IN) IN0 = IN1 - 2 L1 = IV(L1SAV) IN2 = IN1 + 2*L1 - 1 D0 = IV(D) - 1 NG = IV(MAXGRP) XSAVE1 = IV(XSAVE) XSAVE0 = XSAVE1 - 1 RSAVE1 = XSAVE1 + P RSAVE0 = RSAVE1 + N ALP1 = A1 + L*N DELTA = V(DLTFDJ) IV(COVREQ) = -IABS(IV(COVREQ)) C 130 CALL DRNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV, 1 N, L1, P, V, Y) IF (IV(1)-2) 140, 150, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 140 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 IF (L1 .LE. L) GO TO 130 IF (IV(RESTOR) .EQ. 2) CALL DV7CPY(N, V(RSAVE0), V(RSAVE1)) CALL DV7CPY(N, V(RSAVE1), V(ALP1)) GO TO 130 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL)) 1 CALL DV7CPY(N, V(RSAVE0), V(RSAVE1)) GPTR1 = IV(GPTR) DO 230 K = 1, NG CALL DV7CPY(P, V(XSAVE1), ALF) GRP1 = IV(GPTR1) GRP2 = IV(GPTR1+1) - 1 GPTR1 = GPTR1 + 1 DO 160 I1 = GRP1, GRP2 I = IV(I1) XI = ALF(I) J1 = D0 + I DI = V(J1) IF (DI .LE. ZERO) DI = ONE H = DELTA * DMAX1(DABS(XI), ONE/DI) IF (XI .LT. ZERO) H = -H X0I = XSAVE0 + I V(X0I) = XI + H 160 CONTINUE CALL CALCA(N, P, L, V(XSAVE1), IV(NFGCAL), V(DA1), 1 UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .GT. 0) GO TO 170 IV(TOOBIG) = 1 GO TO 130 170 JN1 = IN1 DO 180 I = IN1, IN2 180 IV(I) = 0 PARTJ = IV(MODE) .LE. P DO 220 I1 = GRP1, GRP2 I = IV(I1) DO 210 J1 = 1, L1 IF (INC(J1,I) .EQ. 0) GO TO 210 INI = IN0 + 2*J1 IV(INI) = I IV(INI+1) = J1 X0I = XSAVE0 + I H = ONE / (V(X0I) - ALF(I)) DAJ = DA0 + J1*N IF (PARTJ) GO TO 190 C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. *** AJ = A0 + J1*N CALL DV2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ)) GO TO 200 190 IF (J1 .GT. L) 1 CALL DV2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ)) 200 CALL DV7SCL(N, V(DAJ), H, V(DAJ)) 210 CONTINUE 220 CONTINUE IF (K .GE. NG) GO TO 240 IV(1) = -2 CALL DRNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, 1 LV, N, L1, P, V, Y) IF (-2 .NE. IV(1)) GO TO 999 230 CONTINUE 240 IV(1) = 2 GO TO 130 C 999 RETURN C C *** LAST CARD OF DNSF FOLLOWS *** END SUBROUTINE DNSFB(N, P, L, ALF, B, C, Y, CALCA, INC, IINC, IV, 1 LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING C *** FINITE-DIFFERENCE DERIVATIVES. C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C DOUBLE PRECISION ALF(P), C(L), B(2,P), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) DOUBLE PRECISION ALF(P), C(L), B(2,P), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, UFPARM C C *** PARAMETERS *** C C N (IN) NUMBER OF OBSERVATIONS. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C B (IN) SIMBLE BOUNDS ON ALF.. B(1,I) .LE. ALF(I) .LE. B(2,I). C C (OUT) LINEAR PARAMETERS (ESTIMATED). C Y (IN) RIGHT-HAND SIDE VECTOR. C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX. C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I C OF A DEPENDS ON ALF(J). C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST C 122 + 2*M + 7*P + 2*L + MAX(L+1,6*P), WHERE M IS C THE NUMBER OF ONES IN INC. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + N*(2*L+6+P) + L*(L+3)/2 + P*(2*P + 22). C IF THE LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV C CAN BE 4*N LESS THAN JUST DESCRIBED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA. C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA. C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA. C C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DSM, DRNSGB,DV2AXY,DV7CPY, DV7SCL C C DIVSET.... PROVIDES DEFAULT IV AND V VALUES. C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES. C DRNSGB... CARRIES OUT NL2SOL ALGORITHM. C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C LOGICAL PARTJ INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1, 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1, 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0, 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1 DOUBLE PRECISION DELTA, DI, H, XI, XI1 DOUBLE PRECISION NEGONE, ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED, 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL, 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/, C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/, C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/, C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/, C 4 VNEED/4/, XSAVE/119/ C/7 PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43, 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111, 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47, 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2, 4 VNEED=4, XSAVE=119) C/ DATA NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C LP1 = L + 1 IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 120 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 50 C C *** FRESH START *** C IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1 C C *** CHECK INC, COUNT ITS NONZEROS C L1 = 0 M = 0 DO 40 I = 1, P IF (B(1,I) .GE. B(2,I)) GO TO 40 M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 GO TO 40 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 80 40 CONTINUE C C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 *** C C *** COMPUTE STORAGE REQUIREMENTS *** C IWALEN = MAX0(LP1, 6*P) INLEN = 2 * M IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3 RSVLEN = 2 * L1 * N L1 = L + L1 IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P C 50 CALL DRNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, 1 Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(XSAVE) = IV(DAMAT) + N*L1 IV(NEXTV) = IV(XSAVE) + P + RSVLEN IV(L1SAV) = L1 IV(MSAVE) = M C C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES C *** (SET UP TO CALL DSM) C IN1 = IV(IN) JN1 = IN1 + M DO 70 K = 1, P IF (B(1,K) .GE. B(2,K)) GO TO 70 DO 60 I = 1, LP1 IF (INC(I,K) .EQ. 0) GO TO 60 IV(IN1) = I IN1 = IN1 + 1 IV(JN1) = K JN1 = JN1 + 1 60 CONTINUE 70 CONTINUE IN1 = IV(IN) JN1 = IN1 + M IWA1 = IN1 + INLEN NGRP1 = IWA1 + IWALEN BWA1 = NGRP1 + P IPNTR1 = BWA1 + P JPNTR1 = IPNTR1 + L + 2 CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I, 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1)) IF (I .EQ. 1) GO TO 90 IV(1) = 69 GO TO 50 80 IV(1) = 66 GO TO 50 C C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES C C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1. C 90 IV(MAXGRP) = NG IV(GPTR) = IN1 + 2*L1 GPTR1 = IV(GPTR) IV(GRP) = GPTR1 + NG + 1 IV(NEXTIV) = IV(GRP) + P GRP1 = IV(GRP) NGRP0 = NGRP1 - 1 NGRP2 = NGRP0 + P DO 110 I = 1, NG IV(GPTR1) = GRP1 GPTR1 = GPTR1 + 1 DO 100 I1 = NGRP1, NGRP2 IF (IV(I1) .NE. I) GO TO 100 K = I1 - NGRP0 IF (B(1,K) .GE. B(2,K)) GO TO 100 IV(GRP1) = K GRP1 = GRP1 + 1 100 CONTINUE 110 CONTINUE IV(GPTR1) = GRP1 IF (IV1 .EQ. 13) GO TO 999 C C *** INITIALIZE POINTERS *** C 120 A1 = IV(AMAT) A0 = A1 - N DA1 = IV(DAMAT) DA0 = DA1 - N IN1 = IV(IN) IN0 = IN1 - 2 L1 = IV(L1SAV) IN2 = IN1 + 2*L1 - 1 D0 = IV(D) - 1 NG = IV(MAXGRP) XSAVE1 = IV(XSAVE) XSAVE0 = XSAVE1 - 1 RSAVE1 = XSAVE1 + P RSAVE0 = RSAVE1 + N ALP1 = A1 + L*N DELTA = V(DLTFDJ) IV(COVREQ) = -IABS(IV(COVREQ)) C 130 CALL DRNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, 1 LV, N, L1, P, V, Y) IF (IV(1)-2) 140, 150, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 140 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 IF (L1 .LE. L) GO TO 130 IF (IV(RESTOR) .EQ. 2) CALL DV7CPY(N, V(RSAVE0), V(RSAVE1)) CALL DV7CPY(N, V(RSAVE1), V(ALP1)) GO TO 130 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL)) 1 CALL DV7CPY(N, V(RSAVE0), V(RSAVE1)) GPTR1 = IV(GPTR) DO 260 K = 1, NG CALL DV7CPY(P, V(XSAVE1), ALF) GRP1 = IV(GPTR1) GRP2 = IV(GPTR1+1) - 1 GPTR1 = GPTR1 + 1 DO 180 I1 = GRP1, GRP2 I = IV(I1) XI = ALF(I) J1 = D0 + I DI = V(J1) IF (DI .LE. ZERO) DI = ONE H = DELTA * DMAX1(DABS(XI), ONE/DI) IF (XI .LT. ZERO) GO TO 160 XI1 = XI + H IF (XI1 .LE. B(2,I)) GO TO 170 XI1 = XI - H IF (XI1 .GE. B(1,I)) GO TO 170 GO TO 190 160 XI1 = XI - H IF (XI1 .GE. B(1,I)) GO TO 170 XI1 = XI + H IF (XI1 .LE. B(2,I)) GO TO 170 GO TO 190 170 X0I = XSAVE0 + I V(X0I) = XI1 180 CONTINUE CALL CALCA(N, P, L, V(XSAVE1), NF, V(DA1), UIPARM, URPARM, 1 UFPARM) IF (IV(NFGCAL) .GT. 0) GO TO 200 190 IV(TOOBIG) = 1 GO TO 130 200 JN1 = IN1 DO 210 I = IN1, IN2 210 IV(I) = 0 PARTJ = IV(MODE) .LE. P DO 250 I1 = GRP1, GRP2 I = IV(I1) DO 240 J1 = 1, L1 IF (INC(J1,I) .EQ. 0) GO TO 240 INI = IN0 + 2*J1 IV(INI) = I IV(INI+1) = J1 X0I = XSAVE0 + I H = ONE / (V(X0I) - ALF(I)) DAJ = DA0 + J1*N IF (PARTJ) GO TO 220 C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. *** AJ = A0 + J1*N CALL DV2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ)) GO TO 230 220 IF (J1 .GT. L) 1 CALL DV2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ)) 230 CALL DV7SCL(N, V(DAJ), H, V(DAJ)) 240 CONTINUE 250 CONTINUE IF (K .GE. NG) GO TO 270 IV(1) = -2 CALL DRNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, 1 LIV, LV, N, L1, P, V, Y) IF (-2 .NE. IV(1)) GO TO 999 260 CONTINUE 270 IV(1) = 2 GO TO 130 C 999 RETURN C C *** LAST CARD OF DNSFB FOLLOWS *** END SUBROUTINE DNSG(N, P, L, ALF, C, Y, CALCA, CALCB, INC, IINC, IV, 1 LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING *** C *** ANALYTICALLY COMPUTED DERIVATIVES. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C DOUBLE PRECISION ALF(P), C(L), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) DOUBLE PRECISION ALF(P), C(L), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, CALCB, UFPARM C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), DNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )). C I=1 I I C C THE (L+1)ST TERM IS OPTIONAL. C C-------------------------- PARAMETER USAGE ------------------------- C C INPUT PARAMETERS C C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)). C C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1). C C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0). C C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR C PARAMETERS. C C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW C ON THE CALLING SEQUENCE FOR CALCA. C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING C PROGRAM. C C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA- C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO C ALF -- SEE THE NOTE BELOW ON THE CALLING C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED C EXTERNAL IN THE CALLING PROGRAM. C C Y D.P. ARRAY VECTOR OF OBSERVATIONS. C C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P) C INDICATING THE POSITION OF THE NONLINEAR PARA- C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K) C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0. C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC C MUST CONTAIN AT LEAST ONE 1. C C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT C LEAST L+1. C C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS C THE ITERATION AND FUNCTION EVALUATION LIMITS AND C SWITCHES THAT CONTROL PRINTING. THE INPUT COM- C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE C PORT OPTIMIZATION DOCUMENTATION. C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A C CALL DIVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS C OF IV AND V BEFORE CALLING DNSG. C C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST 115+P+L + 2*M, C WHERE M IS THE NUMBER OF ONES IN INC. C C LV INTEGER LENGTH OF V. MUST BE AT LEAST C 105 + N*(L+M+3) + JLEN + L*(L+3)/2 + P*(2*P+17), C WHERE M IS AS FOR LIV (SEE ABOVE) AND C JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV C CAN BE N LESS THAN JUST DESCRIBED. C C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV C THAT CONTAINS SUCH INPUT COMPONENTS AS THE C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE C THAT V(35) CONTAINS THE INITIAL STEP BOUND, C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW. C C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C C C OUTPUT PARAMETERS C C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS. C C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO C INITIAL GUESS FOR C IS REQUIRED. C C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS C FUNCTION EVALUATION OR ITERATION LIMIT REACHED. C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A C COLUMN OF ZEROS IN INC). NOTE THAT THE C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION. C C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE C THE PORT DOCUMENTATION FOR A COMPLETE LIST. IF C A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST, C FOLLOWED BY LINEAR PARAMETERS. C C C C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM) C C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE C C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE C (L+1)ST COLUMN OF PHI. C C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS C TELLS THE ALGORITHM TO TRY A SMALLER STEP. C C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE C C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED, C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON. C C C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM) C C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA C C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC. C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE, C IF INC HAS THE FORM... C 1 1 0 C 0 1 0 C 1 0 0 C 0 0 1 C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA- C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3). C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO C ALF(3) (FOR I = 1,2,...,N). C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED. C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.) C C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T. C C------------------------------ NOTES ------------------------------- C C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671. C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRNSG C C DIVSET.... PROVIDES DEFAULT IV AND V VALUES. C DRNSG... CARRIES OUT NL2SOL ALGORITHM. C C *** LOCAL VARIABLES *** C INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV, 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/, C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, C 2 PERM/58/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111, 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, 2 PERM=58, TOOBIG=2, VNEED=4) C/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 90 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 60 IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1 LP1 = L + 1 L1 = 0 M = 0 DO 40 I = 1, P M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 50 40 CONTINUE C IV(IVNEED) = IV(IVNEED) + 2*M L1 = L + L1 IV(VNEED) = IV(VNEED) + N*(L1+M) GO TO 60 C 50 IV(1) = 66 C 60 CALL DRNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(NEXTIV) = IV(IN) + 2*M IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(NEXTV) = IV(DAMAT) + N*M IV(L1SAV) = L1 IV(MSAVE) = M C C *** SET UP IN ARRAY *** C IN1 = IV(IN) DO 80 I = 1, P DO 70 K = 1, LP1 IF (INC(K,I) .EQ. 0) GO TO 70 IV(IN1) = I IV(IN1+1) = K IN1 = IN1 + 2 70 CONTINUE 80 CONTINUE IF (IV1 .EQ. 13) GO TO 999 C 90 A1 = IV(AMAT) DA1 = IV(DAMAT) IN1 = IV(IN) L1 = IV(L1SAV) M = IV(MSAVE) C 100 CALL DRNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV, 1 N, M, P, V, Y) IF (IV(1)-2) 110, 120, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 110 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 100 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM, 1 UFPARM) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 100 C 999 RETURN C C *** LAST CARD OF DNSG FOLLOWS *** END SUBROUTINE DNSGB(N, P, L, ALF, B, C, Y, CALCA, CALCB, INC, IINC, 1 IV, LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING *** C *** ANALYTICALLY COMPUTED DERIVATIVES. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C DOUBLE PRECISION ALF(P), B(2,P), C(L), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) DOUBLE PRECISION ALF(P), B(2,P), C(L), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, CALCB, UFPARM C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), DNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) , C I=1 I I C C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS C B(1,I) .LE. ALF(I) .LE. B(2,I), C I = 1(1)P. C C THE (L+1)ST TERM IS OPTIONAL. C C-------------------------- PARAMETER USAGE ------------------------- C C INPUT PARAMETERS C C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)). C C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1). C C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0). C C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR C PARAMETERS. C C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW C ON THE CALLING SEQUENCE FOR CALCA. C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING C PROGRAM. C C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA- C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO C ALF -- SEE THE NOTE BELOW ON THE CALLING C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED C EXTERNAL IN THE CALLING PROGRAM. C C Y D.P. ARRAY VECTOR OF OBSERVATIONS. C C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P) C INDICATING THE POSITION OF THE NONLINEAR PARA- C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K) C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0. C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC C MUST CONTAIN AT LEAST ONE 1. C C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT C LEAST L+1. C C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS C THE ITERATION AND FUNCTION EVALUATION LIMITS AND C SWITCHES THAT CONTROL PRINTING. THE INPUT COM- C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE C PORT OPTIMIZATION DOCUMENTATION. C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A C CALL DIVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS C OF IV AND V BEFORE CALLING DNSGB. C C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST C 115 + 4*P + L + 2*M, C WHERE M IS THE NUMBER OF ONES IN INC. C C LV INTEGER LENGTH OF V. MUST BE AT LEAST C 105 + N*(L+M+P+3) + L*(L+3)/2 + P*(2*P+21), C WHERE M IS AS FOR LIV (SEE ABOVE). IF THE C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV C CAN BE N LESS THAN JUST DESCRIBED. C C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV C THAT CONTAINS SUCH INPUT COMPONENTS AS THE C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE C THAT V(35) CONTAINS THE INITIAL STEP BOUND, C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW. C C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C C C OUTPUT PARAMETERS C C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS. C C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO C INITIAL GUESS FOR C IS REQUIRED. C C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS C FUNCTION EVALUATION OR ITERATION LIMIT REACHED. C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A C COLUMN OF ZEROS IN INC). NOTE THAT THE C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION. C C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE C THE PORT DOCUMENTATION FOR A COMPLETE LIST. C C C C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM) C C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE C C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE C (L+1)ST COLUMN OF PHI. C C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS C TELLS THE ALGORITHM TO TRY A SMALLER STEP. C C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE C C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED, C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON. C C C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM) C C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA C C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC. C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE, C IF INC HAS THE FORM... C 1 1 0 C 0 1 0 C 1 0 0 C 0 0 1 C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA- C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3). C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO C ALF(3) (FOR I = 1,2,...,N). C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED. C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.) C C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T. C C------------------------------ NOTES ------------------------------- C C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671. C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRNSGB C C DIVSET.... PROVIDES DEFAULT IV AND V VALUES. C DRNSGB... CARRIES OUT NL2SOL ALGORITHM. C C *** LOCAL VARIABLES *** C INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV, 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/, C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, C 2 PERM/58/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111, 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, 2 PERM=58, TOOBIG=2, VNEED=4) C/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 90 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 60 IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1 LP1 = L + 1 L1 = 0 M = 0 DO 40 I = 1, P M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 50 40 CONTINUE C IV(IVNEED) = IV(IVNEED) + 2*M L1 = L + L1 IV(VNEED) = IV(VNEED) + N*(L1+M) GO TO 60 C 50 IV(1) = 66 C 60 CALL DRNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, 1 Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(NEXTIV) = IV(IN) + 2*M IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(NEXTV) = IV(DAMAT) + N*M IV(L1SAV) = L1 IV(MSAVE) = M C C *** SET UP IN ARRAY *** C IN1 = IV(IN) DO 80 I = 1, P DO 70 K = 1, LP1 IF (INC(K,I) .EQ. 0) GO TO 70 IV(IN1) = I IV(IN1+1) = K IN1 = IN1 + 2 70 CONTINUE 80 CONTINUE IF (IV1 .EQ. 13) GO TO 999 C 90 A1 = IV(AMAT) DA1 = IV(DAMAT) IN1 = IV(IN) L1 = IV(L1SAV) M = IV(MSAVE) C 100 CALL DRNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, 1 LV, N, M, P, V, Y) IF (IV(1)-2) 110, 120, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 110 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 100 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM, 1 UFPARM) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 100 C 999 RETURN C C *** LAST CARD OF DNSGB FOLLOWS *** END SUBROUTINE DO7PRD(L, LS, P, S, W, Y, Z) C C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E., C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I). C INTEGER L, LS, P DOUBLE PRECISION S(LS), W(L), Y(P,L), Z(P,L) C DIMENSION S(P*(P+1)/2) C INTEGER I, J, K, M DOUBLE PRECISION WK, YI, ZERO DATA ZERO/0.D+0/ C DO 30 K = 1, L WK = W(K) IF (WK .EQ. ZERO) GO TO 30 M = 1 DO 20 I = 1, P YI = WK * Y(I,K) DO 10 J = 1, I S(M) = S(M) + YI*Z(J,K) M = M + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE C 999 RETURN C *** LAST CARD OF DO7PRD FOLLOWS *** END SUBROUTINE DORTHE(NM,N,LOW,IGH,A,ORT) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW DOUBLE PRECISION A(NM,N),ORT(IGH) DOUBLE PRECISION F,G,H,SCALE DOUBLE PRECISION DSQRT C C THIS IS A DOUBLE-PRECISION VERSION OF THE C EISPACK SINGLE-PRECISION ROUTINE ORTHES. C IT WAS ADAPTED BY PHYLLIS FOX, MAY 28, 1975. C C ORTHES IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL (DOUBLE PRECISION) GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT- C C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLE UNDER THE C HESSENBERG MATRIX, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C C ------------------------------------------------------------------ C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.0D0 ORT(M) = 0.0D0 SCALE = 0.0D0 C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ********** DO 90 I = M, IGH 90 SCALE = SCALE + DABS(A(I,M-1)) C IF (SCALE .EQ. 0.0D0) GO TO 180 MP = M + IGH C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 100 II = M, IGH I = MP - II ORT(I) = A(I,M-1) / SCALE H = H + ORT(I) * ORT(I) 100 CONTINUE C G = -DSIGN(DSQRT(H),ORT(M)) H = H - ORT(M) * G ORT(M) = ORT(M) - G C ********** FORM (I-(U*UT)/H) * A ********** DO 130 J = M, N F = 0.0D0 C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 110 II = M, IGH I = MP - II F = F + ORT(I) * A(I,J) 110 CONTINUE C F = F / H C DO 120 I = M, IGH 120 A(I,J) = A(I,J) - F * ORT(I) C 130 CONTINUE C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ********** DO 160 I = 1, IGH F = 0.0D0 C ********** FOR J=IGH STEP -1 UNTIL M DO -- ********** DO 140 JJ = M, IGH J = MP - JJ F = F + ORT(J) * A(I,J) 140 CONTINUE C F = F / H C DO 150 J = M, IGH 150 A(I,J) = A(I,J) - F * ORT(J) C 160 CONTINUE C ORT(M) = SCALE * ORT(M) A(M,M-1) = SCALE * G 180 CONTINUE C 200 RETURN C ********** LAST CARD OF DORTHE ********** END SUBROUTINE DORTRA(NM,N,LOW,IGH,A,ORT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N) DOUBLE PRECISION G C C THIS IS A DOUBLE-PRECISION VERSION OF THE C EISPACK SINGLE-PRECISION ROUTINE ORTRAN. C IT WAS ADAPTED BY PHYLLIS FOX, MAY 28, 1975. C C ORTRAN IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL C MATRIX TO UPPER HESSENBERG FORM BY DORTHE. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION BY DORTHE C IN ITS STRICT LOWER TRIANGLE, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- C FORMATIONS USED IN THE REDUCTION BY DORTHE. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY DORTHE, C C ORT HAS BEEN ALTERED. C C C ------------------------------------------------------------------ C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0D0 C Z(I,I) = 1.0D0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.0D0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN DORTHE. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN C ********** LAST CARD OF DORTRA ********** END SUBROUTINE DPARCK(ALG, D, IV, LIV, LV, N, V) C C *** CHECK ***SOL (VERSION 2.3) PARAMETERS, PRINT CHANGED VALUES *** C C *** ALG = 1 FOR REGRESSION, ALG = 2 FOR GENERAL UNCONSTRAINED OPT. C INTEGER ALG, LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION D(N), V(LV) C DOUBLE PRECISION DR7MDC EXTERNAL DIVSET, DR7MDC,DV7CPY,DV7DFL C DIVSET -- SUPPLIES DEFAULT VALUES TO BOTH IV AND V. C DR7MDC -- RETURNS MACHINE-DEPENDENT CONSTANTS. C DV7CPY -- COPIES ONE VECTOR TO ANOTHER. C DV7DFL -- SUPPLIES DEFAULT PARAMETER VALUES TO V ALONE. C C *** LOCAL VARIABLES *** C INTEGER ALG1, I, II, IV1, J, K, L, M, MIV1, MIV2, NDFALT, PARSV1, 1 PU INTEGER IJMP, JLIM(4), MINIV(4), NDFLT(4) C/6S C INTEGER VARNM(2), SH(2) C REAL CNGD(3), DFLT(3), VN(2,34), WHICH(3) C/7S CHARACTER*1 VARNM(2), SH(2) CHARACTER*4 CNGD(3), DFLT(3), VN(2,34), WHICH(3) C/ DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(34), VX(34), ZERO C C *** IV AND V SUBSCRIPTS *** C INTEGER ALGSAV, DINIT, DTYPE, DTYPE0, EPSLON, INITS, IVNEED, 1 LASTIV, LASTV, LMAT, NEXTIV, NEXTV, NVDFLT, OLDN, 2 PARPRT, PARSAV, PERM, PRUNIT, VNEED C C C/6 C DATA ALGSAV/51/, DINIT/38/, DTYPE/16/, DTYPE0/54/, EPSLON/19/, C 1 INITS/25/, IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/, C 2 NEXTIV/46/, NEXTV/47/, NVDFLT/50/, OLDN/38/, PARPRT/20/, C 3 PARSAV/49/, PERM/58/, PRUNIT/21/, VNEED/4/ C/7 PARAMETER (ALGSAV=51, DINIT=38, DTYPE=16, DTYPE0=54, EPSLON=19, 1 INITS=25, IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, 2 NEXTIV=46, NEXTV=47, NVDFLT=50, OLDN=38, PARPRT=20, 3 PARSAV=49, PERM=58, PRUNIT=21, VNEED=4) SAVE BIG, MACHEP, TINY C/ C DATA BIG/0.D+0/, MACHEP/-1.D+0/, TINY/1.D+0/, ZERO/0.D+0/ C/6S C DATA VN(1,1),VN(2,1)/4HEPSL,4HON../ C DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../ C DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../ C DATA VN(1,4),VN(2,4)/4HDECF,4HAC../ C DATA VN(1,5),VN(2,5)/4HINCF,4HAC../ C DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../ C DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../ C DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../ C DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../ C DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../ C DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../ C DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../ C DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../ C DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../ C DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../ C DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../ C DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../ C DATA VN(1,18),VN(2,18)/4HLMAX,4HS.../ C DATA VN(1,19),VN(2,19)/4HSCTO,4HL.../ C DATA VN(1,20),VN(2,20)/4HDINI,4HT.../ C DATA VN(1,21),VN(2,21)/4HDTIN,4HIT../ C DATA VN(1,22),VN(2,22)/4HD0IN,4HIT../ C DATA VN(1,23),VN(2,23)/4HDFAC,4H..../ C DATA VN(1,24),VN(2,24)/4HDLTF,4HDC../ C DATA VN(1,25),VN(2,25)/4HDLTF,4HDJ../ C DATA VN(1,26),VN(2,26)/4HDELT,4HA0../ C DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../ C DATA VN(1,28),VN(2,28)/4HRLIM,4HIT../ C DATA VN(1,29),VN(2,29)/4HCOSM,4HIN../ C DATA VN(1,30),VN(2,30)/4HHUBE,4HRC../ C DATA VN(1,31),VN(2,31)/4HRSPT,4HOL../ C DATA VN(1,32),VN(2,32)/4HSIGM,4HIN../ C DATA VN(1,33),VN(2,33)/4HETA0,4H..../ C DATA VN(1,34),VN(2,34)/4HBIAS,4H..../ C/7S DATA VN(1,1),VN(2,1)/'EPSL','ON..'/ DATA VN(1,2),VN(2,2)/'PHMN','FC..'/ DATA VN(1,3),VN(2,3)/'PHMX','FC..'/ DATA VN(1,4),VN(2,4)/'DECF','AC..'/ DATA VN(1,5),VN(2,5)/'INCF','AC..'/ DATA VN(1,6),VN(2,6)/'RDFC','MN..'/ DATA VN(1,7),VN(2,7)/'RDFC','MX..'/ DATA VN(1,8),VN(2,8)/'TUNE','R1..'/ DATA VN(1,9),VN(2,9)/'TUNE','R2..'/ DATA VN(1,10),VN(2,10)/'TUNE','R3..'/ DATA VN(1,11),VN(2,11)/'TUNE','R4..'/ DATA VN(1,12),VN(2,12)/'TUNE','R5..'/ DATA VN(1,13),VN(2,13)/'AFCT','OL..'/ DATA VN(1,14),VN(2,14)/'RFCT','OL..'/ DATA VN(1,15),VN(2,15)/'XCTO','L...'/ DATA VN(1,16),VN(2,16)/'XFTO','L...'/ DATA VN(1,17),VN(2,17)/'LMAX','0...'/ DATA VN(1,18),VN(2,18)/'LMAX','S...'/ DATA VN(1,19),VN(2,19)/'SCTO','L...'/ DATA VN(1,20),VN(2,20)/'DINI','T...'/ DATA VN(1,21),VN(2,21)/'DTIN','IT..'/ DATA VN(1,22),VN(2,22)/'D0IN','IT..'/ DATA VN(1,23),VN(2,23)/'DFAC','....'/ DATA VN(1,24),VN(2,24)/'DLTF','DC..'/ DATA VN(1,25),VN(2,25)/'DLTF','DJ..'/ DATA VN(1,26),VN(2,26)/'DELT','A0..'/ DATA VN(1,27),VN(2,27)/'FUZZ','....'/ DATA VN(1,28),VN(2,28)/'RLIM','IT..'/ DATA VN(1,29),VN(2,29)/'COSM','IN..'/ DATA VN(1,30),VN(2,30)/'HUBE','RC..'/ DATA VN(1,31),VN(2,31)/'RSPT','OL..'/ DATA VN(1,32),VN(2,32)/'SIGM','IN..'/ DATA VN(1,33),VN(2,33)/'ETA0','....'/ DATA VN(1,34),VN(2,34)/'BIAS','....'/ C/ C DATA VM(1)/1.0D-3/, VM(2)/-0.99D+0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/, 1 VM(5)/1.2D+0/, VM(6)/1.D-2/, VM(7)/1.2D+0/, VM(8)/0.D+0/, 2 VM(9)/0.D+0/, VM(10)/1.D-3/, VM(11)/-1.D+0/, VM(13)/0.D+0/, 3 VM(15)/0.D+0/, VM(16)/0.D+0/, VM(19)/0.D+0/, VM(20)/-10.D+0/, 4 VM(21)/0.D+0/, VM(22)/0.D+0/, VM(23)/0.D+0/, VM(27)/1.01D+0/, 5 VM(28)/1.D+10/, VM(30)/0.D+0/, VM(31)/0.D+0/, VM(32)/0.D+0/, 6 VM(34)/0.D+0/ DATA VX(1)/0.9D+0/, VX(2)/-1.D-3/, VX(3)/1.D+1/, VX(4)/0.8D+0/, 1 VX(5)/1.D+2/, VX(6)/0.8D+0/, VX(7)/1.D+2/, VX(8)/0.5D+0/, 2 VX(9)/0.5D+0/, VX(10)/1.D+0/, VX(11)/1.D+0/, VX(14)/0.1D+0/, 3 VX(15)/1.D+0/, VX(16)/1.D+0/, VX(19)/1.D+0/, VX(23)/1.D+0/, 4 VX(24)/1.D+0/, VX(25)/1.D+0/, VX(26)/1.D+0/, VX(27)/1.D+10/, 5 VX(29)/1.D+0/, VX(31)/1.D+0/, VX(32)/1.D+0/, VX(33)/1.D+0/, 6 VX(34)/1.D+0/ C C/6S C DATA VARNM(1)/1HP/, VARNM(2)/1HP/, SH(1)/1HS/, SH(2)/1HH/ C DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/, C 1 DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/ C/7S DATA VARNM(1)/'P'/, VARNM(2)/'P'/, SH(1)/'S'/, SH(2)/'H'/ DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ C/ DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/, 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/ C C............................... BODY ................................ C PU = 0 IF (PRUNIT .LE. LIV) PU = IV(PRUNIT) IF (ALGSAV .GT. LIV) GO TO 20 IF (ALG .EQ. IV(ALGSAV)) GO TO 20 IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV) 10 FORMAT(/40H THE FIRST PARAMETER TO DIVSET SHOULD BE,I3, 1 12H RATHER THAN,I3) IV(1) = 67 GO TO 999 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340 MIV1 = MINIV(ALG) IF (IV(1) .EQ. 15) GO TO 360 ALG1 = MOD(ALG-1,2) + 1 IF (IV(1) .EQ. 0) CALL DIVSET(ALG, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30 IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1) IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2 IF (LIV .LT. MIV1) GO TO 300 IV(IVNEED) = 0 IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1 IV(VNEED) = 0 IF (LIV .LT. MIV2) GO TO 300 IF (LV .LT. IV(LASTV)) GO TO 320 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60 IF (N .GE. 1) GO TO 50 IV(1) = 81 IF (PU .EQ. 0) GO TO 999 WRITE(PU,40) VARNM(ALG1), N 40 FORMAT(/8H /// BAD,A1,2H =,I5) GO TO 999 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM) IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT) IF (IV1 .EQ. 13) GO TO 999 K = IV(PARSAV) - EPSLON CALL DV7DFL(ALG1, LV-K, V(K+1)) IV(DTYPE0) = 2 - ALG1 IV(OLDN) = N WHICH(1) = DFLT(1) WHICH(2) = DFLT(2) WHICH(3) = DFLT(3) GO TO 110 60 IF (N .EQ. IV(OLDN)) GO TO 80 IV(1) = 17 IF (PU .EQ. 0) GO TO 999 WRITE(PU,70) VARNM(ALG1), IV(OLDN), N 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5) GO TO 999 C 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100 IV(1) = 80 IF (PU .NE. 0) WRITE(PU,90) IV1 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.) GO TO 999 C 100 WHICH(1) = CNGD(1) WHICH(2) = CNGD(2) WHICH(3) = CNGD(3) C 110 IF (IV1 .EQ. 14) IV1 = 12 IF (BIG .GT. TINY) GO TO 120 TINY = DR7MDC(1) MACHEP = DR7MDC(3) BIG = DR7MDC(6) VM(12) = MACHEP VX(12) = BIG VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = TINY VX(18) = BIG VX(20) = BIG VX(21) = BIG VX(22) = BIG VM(24) = MACHEP VM(25) = MACHEP VM(26) = MACHEP VX(28) = DR7MDC(5) VM(29) = MACHEP VX(30) = BIG VM(33) = MACHEP 120 M = 0 I = 1 J = JLIM(ALG1) K = EPSLON NDFALT = NDFLT(ALG1) DO 150 L = 1, NDFALT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140 M = K IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK, 1 VM(I), VX(I) 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,D11.3,7H SHOULD, 1 11H BE BETWEEN,D11.3,4H AND,D11.3) 140 K = K + 1 I = I + 1 IF (I .EQ. J) I = IJMP 150 CONTINUE C IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170 IV(1) = 51 IF (PU .EQ. 0) GO TO 999 WRITE(PU,160) IV(NVDFLT), NDFALT 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5) GO TO 999 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12) 1 GO TO 200 DO 190 I = 1, N IF (D(I) .GT. ZERO) GO TO 190 M = 18 IF (PU .NE. 0) WRITE(PU,180) I, D(I) 180 FORMAT(/8H /// D(,I3,3H) =,D11.3,19H SHOULD BE POSITIVE) 190 CONTINUE 200 IF (M .EQ. 0) GO TO 210 IV(1) = M GO TO 999 C 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230 M = 1 WRITE(PU,220) SH(ALG1), IV(INITS) 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =, 1 I3) 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250 IF (M .EQ. 0) WRITE(PU,260) WHICH M = 1 WRITE(PU,240) IV(DTYPE) 240 FORMAT(20H DTYPE..... IV(16) =,I3) 250 I = 1 J = JLIM(ALG1) K = EPSLON L = IV(PARSAV) NDFALT = NDFLT(ALG1) DO 290 II = 1, NDFALT IF (V(K) .EQ. V(L)) GO TO 280 IF (M .EQ. 0) WRITE(PU,260) WHICH 260 FORMAT(/1H ,3A4,9HALUES..../) M = 1 WRITE(PU,270) VN(1,I), VN(2,I), K, V(K) 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,D15.7) 280 K = K + 1 L = L + 1 I = I + 1 IF (I .EQ. J) I = IJMP 290 CONTINUE C IV(DTYPE0) = IV(DTYPE) PARSV1 = IV(PARSAV) CALL DV7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON)) GO TO 999 C 300 IV(1) = 15 IF (PU .EQ. 0) GO TO 999 WRITE(PU,310) LIV, MIV2 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5) IF (LIV .LT. MIV1) GO TO 999 IF (LV .LT. IV(LASTV)) GO TO 320 GO TO 999 C 320 IV(1) = 16 IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV) 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5) GO TO 999 C 340 IV(1) = 67 IF (PU .NE. 0) WRITE(PU,350) ALG 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4) GO TO 999 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5, 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1 IF (LASTV .LE. LIV) IV(LASTV) = 0 C 999 RETURN C *** LAST LINE OF DPARCK FOLLOWS *** END SUBROUTINE DQ7APL(NN, N, P, J, R, IERR) C *****PARAMETERS. INTEGER NN, N, P, IERR DOUBLE PRECISION J(NN,P), R(N) C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS C STORED IN J BY QRFACT C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN C THE CALLING PROGRAM DIMENSION STATEMENT C C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R C C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA C C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C IDENT - U*U.TRANSPOSE C C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL C TRANSFORMATIONS WILL BE APPLIED C C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED C C ON OUTPUT. C C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE C C *****APPLICATION AND USAGE RESTRICTIONS. C NONE C C *****ALGORITHM NOTES. C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE USE OF C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1). C C *****SUBROUTINES AND FUNCTIONS CALLED. C C DD7TPR - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS C C *****REFERENCES. C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7, C PP. 269-276. C C *****HISTORY. C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977) C CALL ON DV2AXY SUBSTITUTED FOR DO LOOP, FALL 1983. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *****LOCAL VARIABLES. INTEGER K, L, NL1 C *****FUNCTIONS. DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR,DV2AXY C C *** BODY *** C K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 IF ( K .EQ. 0) GO TO 999 C DO 20 L = 1, K NL1 = N - L + 1 CALL DV2AXY(NL1, R(L), -DD7TPR(NL1,J(L,L),R(L)), J(L,L), R(L)) 20 CONTINUE C 999 RETURN C *** LAST LINE OF DQ7APL FOLLOWS *** END SUBROUTINE DQ7RAD(N, NN, P, QTR, QTRSET, RMAT, W, Y) C C *** ADD ROWS W TO QR FACTORIZATION WITH R MATRIX RMAT AND C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENTS OF RESIDUAL C *** CORRESPONDING TO W. QTR, Y REFERENCED ONLY IF QTRSET = .TRUE. C LOGICAL QTRSET INTEGER N, NN, P DOUBLE PRECISION QTR(P), RMAT(1), W(NN,P), Y(N) C DIMENSION RMAT(P*(P+1)/2) C/+ DOUBLE PRECISION DSQRT C/ DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCL, DV2NRM C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IP1, J, K, NK DOUBLE PRECISION ARI, QRI, RI, S, T, WI DOUBLE PRECISION BIG, BIGRT, ONE, TINY, TINYRT, ZERO C/7 SAVE BIGRT, TINY, TINYRT C/ DATA BIG/-1.D+0/, BIGRT/-1.D+0/, ONE/1.D+0/, TINY/0.D+0/, 1 TINYRT/0.D+0/, ZERO/0.D+0/ C C------------------------------ BODY ----------------------------------- C IF (TINY .GT. ZERO) GO TO 10 TINY = DR7MDC(1) BIG = DR7MDC(6) IF (TINY*BIG .LT. ONE) TINY = ONE / BIG 10 K = 1 NK = N II = 0 DO 180 I = 1, P II = II + I IP1 = I + 1 IJ = II + I IF (NK .LE. 1) T = DABS(W(K,I)) IF (NK .GT. 1) T = DV2NRM(NK, W(K,I)) IF (T .LT. TINY) GOTO 180 RI = RMAT(II) IF (RI .NE. ZERO) GO TO 100 IF (NK .GT. 1) GO TO 30 IJ = II DO 20 J = I, P RMAT(IJ) = W(K,J) IJ = IJ + J 20 CONTINUE IF (QTRSET) QTR(I) = Y(K) W(K,I) = ZERO GO TO 999 30 WI = W(K,I) IF (BIGRT .GT. ZERO) GO TO 40 BIGRT = DR7MDC(5) TINYRT = DR7MDC(2) 40 IF (T .LE. TINYRT) GO TO 50 IF (T .GE. BIGRT) GO TO 50 IF (WI .LT. ZERO) T = -T WI = WI + T S = DSQRT(T * WI) GO TO 70 50 S = DSQRT(T) IF (WI .LT. ZERO) GO TO 60 WI = WI + T S = S * DSQRT(WI) GO TO 70 60 T = -T WI = WI + T S = S * DSQRT(-WI) 70 W(K,I) = WI CALL DV7SCL(NK, W(K,I), ONE/S, W(K,I)) RMAT(II) = -T IF (.NOT. QTRSET) GO TO 80 CALL DV2AXY(NK, Y(K), -DD7TPR(NK,Y(K),W(K,I)), W(K,I), Y(K)) QTR(I) = Y(K) 80 IF (IP1 .GT. P) GO TO 999 DO 90 J = IP1, P CALL DV2AXY(NK, W(K,J), -DD7TPR(NK,W(K,J),W(K,I)), 1 W(K,I), W(K,J)) RMAT(IJ) = W(K,J) IJ = IJ + J 90 CONTINUE IF (NK .LE. 1) GO TO 999 K = K + 1 NK = NK - 1 GO TO 180 C 100 ARI = DABS(RI) IF (ARI .GT. T) GO TO 110 T = T * DSQRT(ONE + (ARI/T)**2) GO TO 120 110 T = ARI * DSQRT(ONE + (T/ARI)**2) 120 IF (RI .LT. ZERO) T = -T RI = RI + T RMAT(II) = -T S = -RI / T IF (NK .LE. 1) GO TO 150 CALL DV7SCL(NK, W(K,I), ONE/RI, W(K,I)) IF (.NOT. QTRSET) GO TO 130 QRI = QTR(I) T = S * ( QRI + DD7TPR(NK, Y(K), W(K,I)) ) QTR(I) = QRI + T 130 IF (IP1 .GT. P) GO TO 999 IF (QTRSET) CALL DV2AXY(NK, Y(K), T, W(K,I), Y(K)) DO 140 J = IP1, P RI = RMAT(IJ) T = S * ( RI + DD7TPR(NK, W(K,J), W(K,I)) ) CALL DV2AXY(NK, W(K,J), T, W(K,I), W(K,J)) RMAT(IJ) = RI + T IJ = IJ + J 140 CONTINUE GO TO 180 C 150 WI = W(K,I) / RI W(K,I) = WI IF (.NOT. QTRSET) GO TO 160 QRI = QTR(I) T = S * ( QRI + Y(K)*WI ) QTR(I) = QRI + T 160 IF (IP1 .GT. P) GO TO 999 IF (QTRSET) Y(K) = T*WI + Y(K) DO 170 J = IP1, P RI = RMAT(IJ) T = S * (RI + W(K,J)*WI) W(K,J) = W(K,J) + T*WI RMAT(IJ) = RI + T IJ = IJ + J 170 CONTINUE 180 CONTINUE C 999 RETURN C *** LAST LINE OF DQ7RAD FOLLOWS *** END SUBROUTINE DQ7RFH(IERR, IPIVOT, N, NN, NOPIVK, P, Q, R, RLEN, W) C C *** COMPUTE QR FACTORIZATION VIA HOUSEHOLDER TRANSFORMATIONS C *** WITH COLUMN PIVOTING *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, N, NN, NOPIVK, P, RLEN INTEGER IPIVOT(P) DOUBLE PRECISION Q(NN,P), R(RLEN), W(P) C DIMENSION R(P*(P+1)/2) C C---------------------------- DESCRIPTION ---------------------------- C C THIS ROUTINE COMPUTES A QR FACTORIZATION (VIA HOUSEHOLDER TRANS- C FORMATIONS) OF THE MATRIX A THAT ON INPUT IS STORED IN Q. C IF NOPIVK ALLOWS IT, THIS ROUTINE DOES COLUMN PIVOTING -- IF C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING. C THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF Q*R EQUALS C COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UPPER TRIANGULAR C MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., THE OUTPUT VECTOR R C CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), R(2,3), ..., R(P,P) (IN C THAT ORDER). IF ALL GOES WELL, THEN THIS ROUTINE SETS IERR = 0. C BUT IF (PERMUTED) COLUMN K OF A IS LINEARLY DEPENDENT ON C (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR IS SET TO K AND THE R C MATRIX RETURNED HAS R(I,J) = 0 FOR I .GE. K AND J .GE. K. C THE ORIGINAL MATRIX A IS AN N BY P MATRIX. NN IS THE LEAD C DIMENSION OF THE ARRAY Q AND MUST SATISFY NN .GE. N. NO C PARAMETER CHECKING IS DONE. C PIVOTING IS DONE AS THOUGH ALL COLUMNS OF Q WERE FIRST C SCALED TO HAVE THE SAME NORM. IF COLUMN K IS ELIGIBLE FOR C PIVOTING AND ITS (SCALED) NORM**2 LOSS IS MORE THAN THE C MINIMUM SUCH LOSS (OVER COLUMNS K THRU P), THEN COLUMN K IS C SWAPPED WITH THE COLUMN OF LEAST NORM**2 LOSS. C C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984). C C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I, II, J, K, KK, KM1, KP1, NK1 DOUBLE PRECISION AK, QKK, S, SINGTL, T, T1, WK DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCL, DV7SCP,DV7SWP, DV2NRM C/+ DOUBLE PRECISION DSQRT C/ DOUBLE PRECISION BIG, BIGRT, MEPS10, ONE, TEN, TINY, TINYRT, 1 WTOL, ZERO C/6 C DATA ONE/1.0D+0/, TEN/1.D+1/, WTOL/0.75D+0/, ZERO/0.0D+0/ C/7 PARAMETER (ONE=1.0D+0, TEN=1.D+1, WTOL=0.75D+0, ZERO=0.0D+0) SAVE BIGRT, MEPS10, TINY, TINYRT C/ DATA BIGRT/0.0D+0/, MEPS10/0.0D+0/, TINY/0.D+0/, TINYRT/0.D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IERR = 0 IF (MEPS10 .GT. ZERO) GO TO 10 BIGRT = DR7MDC(5) MEPS10 = TEN * DR7MDC(3) TINYRT = DR7MDC(2) TINY = DR7MDC(1) BIG = DR7MDC(6) IF (TINY*BIG .LT. ONE) TINY = ONE / BIG 10 SINGTL = FLOAT(MAX0(N,P)) * MEPS10 C C *** INITIALIZE W, IPIVOT, AND DIAG(R) *** C J = 0 DO 40 I = 1, P IPIVOT(I) = I T = DV2NRM(N, Q(1,I)) IF (T .GT. ZERO) GO TO 20 W(I) = ONE GO TO 30 20 W(I) = ZERO 30 J = J + I R(J) = T 40 CONTINUE C C *** MAIN LOOP *** C KK = 0 NK1 = N + 1 DO 130 K = 1, P IF (NK1 .LE. 1) GO TO 999 NK1 = NK1 - 1 KK = KK + K KP1 = K + 1 IF (K .LE. NOPIVK) GO TO 60 IF (K .GE. P) GO TO 60 C C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS *** C T = W(K) IF (T .LE. ZERO) GO TO 60 J = K DO 50 I = KP1, P IF (W(I) .GE. T) GO TO 50 T = W(I) J = I 50 CONTINUE IF (J .EQ. K) GO TO 60 C C *** INTERCHANGE COLUMNS K AND J *** C I = IPIVOT(K) IPIVOT(K) = IPIVOT(J) IPIVOT(J) = I W(J) = W(K) W(K) = T I = J*(J+1)/2 T1 = R(I) R(I) = R(KK) R(KK) = T1 CALL DV7SWP(N, Q(1,K), Q(1,J)) IF (K .LE. 1) GO TO 60 I = I - J + 1 J = KK - K + 1 CALL DV7SWP(K-1, R(I), R(J)) C C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE C *** WHETHER TO REORTHOGONALIZE IT. C 60 AK = R(KK) IF (AK .LE. ZERO) GO TO 140 WK = W(K) C C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K)) C *** AND CHECK FOR SINGULARITY. C IF (WK .LT. WTOL) GO TO 70 T = DV2NRM(NK1, Q(K,K)) IF (T / AK .LE. SINGTL) GO TO 140 GO TO 80 70 T = DSQRT(ONE - WK) IF (T .LE. SINGTL) GO TO 140 T = T * AK C C *** DETERMINE HOUSEHOLDER TRANSFORMATION *** C 80 QKK = Q(K,K) IF (T .LE. TINYRT) GO TO 90 IF (T .GE. BIGRT) GO TO 90 IF (QKK .LT. ZERO) T = -T QKK = QKK + T S = DSQRT(T * QKK) GO TO 110 90 S = DSQRT(T) IF (QKK .LT. ZERO) GO TO 100 QKK = QKK + T S = S * DSQRT(QKK) GO TO 110 100 T = -T QKK = QKK + T S = S * DSQRT(-QKK) 110 Q(K,K) = QKK C C *** SCALE (Q(K,K),...,Q(N,K)) TO HAVE NORM SQRT(2) *** C IF (S .LE. TINY) GO TO 140 CALL DV7SCL(NK1, Q(K,K), ONE/S, Q(K,K)) C R(KK) = -T C C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q *** C IF (K .GE. P) GO TO 999 J = KK + K II = KK DO 120 I = KP1, P II = II + I CALL DV2AXY(NK1, Q(K,I), -DD7TPR(NK1,Q(K,K),Q(K,I)), 1 Q(K,K), Q(K,I)) T = Q(K,I) R(J) = T J = J + I T1 = R(II) IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2 120 CONTINUE 130 CONTINUE C C *** SINGULAR Q *** C 140 IERR = K KM1 = K - 1 J = KK DO 150 I = K, P CALL DV7SCP(I-KM1, R(J), ZERO) J = J + I 150 CONTINUE C 999 RETURN C *** LAST CARD OF DQ7RFH FOLLOWS *** END SUBROUTINE DQ7RGS(IERR, IPIVOT, L, N, NN, NOPIVK, P, Q, R, W) C C *** COMPUTE QR FACTORIZATION VIA MODIFIED GRAM-SCHMIDT PROCEDURE C *** WITH COLUMN PIVOTING *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, L, N, NN, NOPIVK, P INTEGER IPIVOT(P) DOUBLE PRECISION Q(NN,P), R(1), W(P) C DIMENSION R(P*(P+1)/2) C C---------------------------- DESCRIPTION ---------------------------- C C THIS ROUTINE COMPUTES COLUMNS L THROUGH P OF A QR FACTORI- C ZATION OF THE MATRIX A THAT IS ORIGINALLY STORED IN COLUMNS L C THROUGH P OF Q. IT IS ASSUMED THAT COLUMNS 1 THROUGH L-1 OF C THE FACTORIZATION HAVE ALREADY BEEN STORED IN Q AND R. THIS C CODE USES THE MODIFIED GRAM-SCHMIDT PROCEDURE WITH REORTHOGONALI- C ZATION AND, IF NOPIVK ALLOWS IT, WITH COLUMN PIVOTING -- IF C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING. C IF IPIVOT(L) = 0 ON INPUT, THEN IPIVOT IS INITIALIZED SO THAT C IPIVOT(I) = I FOR I = L,...,P. WHATEVER THE ORIGINAL VALUE OF C IPIVOT(L), THE CORRESPONDING ELEMENTS OF IPIVOT ARE INTERCHANGED C WHENEVER COLUMN PIVOTING OCCURS. THUS IF IPIVOT(L) = 0 ON IN- C PUT, THEN THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF C Q*R EQUALS COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UP- C PER TRIANGULAR MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., C THE OUTPUT VECTOR R CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), C R(2,3), ..., R(P,P) (IN THAT ORDER). IF ALL GOES WELL, THEN THIS C ROUTINE SETS IERR = 0. BUT IF (PERMUTED) COLUMN K OF A IS C LINEARLY DEPENDENT ON (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR C IS SET TO K AND THE R MATRIX RETURNED HAS R(I,J) = 0 FOR C I .GE. K AND J .GE. K. IN THIS CASE COLUMNS K THROUGH P C OF THE Q RETURNED ARE NOT ORTHONORMAL. W IS A SCRATCH VECTOR. C THE ORIGINAL MATRIX A AND THE COMPUTED ORTHOGONAL MATRIX Q C ARE N BY P MATRICES. NN IS THE LEAD DIMENSION OF THE ARRAY Q C AND MUST SATISFY NN .GE. N. NO PARAMETER CHECKING IS DONE. C C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984). C C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I, II, J, K, KK, KM1, KP1, LM1 LOGICAL IPINIT DOUBLE PRECISION AK, SINGTL, T, T1, T2, WK EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCP,DV7SWP, DV2NRM, DV7SCL DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM C/+ DOUBLE PRECISION DSQRT C/ DOUBLE PRECISION BIG, MEPS10, ONE, REOTOL, TEN, TINY, WTOL, ZERO C/6 C DATA ONE/1.0D+0/, REOTOL/0.25D+0/, TEN/1.D+1/, WTOL/0.75D+0/, C 1 ZERO/0.0D+0/ C/7 PARAMETER (ONE=1.0D+0, REOTOL=0.25D+0, TEN=1.D+1, WTOL=0.75D+0, 1 ZERO=0.0D+0) SAVE MEPS10, TINY C/ DATA MEPS10/0.0D+0/, TINY/0.0D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IERR = 0 IF (MEPS10 .GT. ZERO) GO TO 10 MEPS10 = TEN * DR7MDC(3) TINY = DR7MDC(1) BIG = DR7MDC(6) IF (TINY*BIG .LT. ONE) TINY = ONE / BIG 10 SINGTL = FLOAT(MAX0(N,P)) * MEPS10 LM1 = L - 1 J = L*LM1/2 KK = J IPINIT = IPIVOT(L) .EQ. 0 C C *** INITIALIZE W, IPIVOT, DIAG(R), AND R(I,J) FOR I = 1,2,...,L-1 C *** AND J = L,L+1,...,P. C DO 50 I = L, P IF (IPINIT) IPIVOT(I) = I T = DV2NRM(N, Q(1,I)) IF (T .GT. ZERO) GO TO 20 W(I) = ONE J = J + LM1 GO TO 40 20 W(I) = ZERO IF (LM1 .EQ. 0) GO TO 40 DO 30 K = 1, LM1 J = J + 1 T1 = DD7TPR(N, Q(1,K), Q(1,I)) R(J) = T1 CALL DV2AXY(N, Q(1,I), -T1, Q(1,K), Q(1,I)) W(I) = W(I) + (T1/T)**2 30 CONTINUE 40 J = J + I - LM1 R(J) = T 50 CONTINUE C C *** MAIN LOOP *** C DO 140 K = L, P KK = KK + K KP1 = K + 1 IF (K .LE. NOPIVK) GO TO 70 IF (K .GE. P) GO TO 70 C C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS *** C T = W(K) IF (T .LE. ZERO) GO TO 70 J = K DO 60 I = KP1, P IF (W(I) .GE. T) GO TO 60 T = W(I) J = I 60 CONTINUE IF (J .EQ. K) GO TO 70 C C *** INTERCHANGE COLUMNS K AND J *** C I = IPIVOT(K) IPIVOT(K) = IPIVOT(J) IPIVOT(J) = I W(J) = W(K) W(K) = T I = J*(J+1)/2 T1 = R(I) R(I) = R(KK) R(KK) = T1 CALL DV7SWP(N, Q(1,K), Q(1,J)) IF (K .LE. 1) GO TO 70 I = I - J + 1 J = KK - K + 1 CALL DV7SWP(K-1, R(I), R(J)) C C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE C *** WHETHER TO REORTHOGONALIZE IT. C 70 AK = R(KK) IF (AK .LE. ZERO) GO TO 150 T1 = AK R(KK) = ONE T2 = ONE WK = W(K) C C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K)) C *** AND CHECK FOR SINGULARITY. C 80 IF (WK .LT. WTOL) GO TO 90 T = DV2NRM(N, Q(1,K)) IF (T*T2 / AK .GT. SINGTL) GO TO 100 GO TO 150 90 T = DSQRT(ONE - WK) IF (T*T2 .LE. SINGTL) GO TO 150 T = T * AK C 100 IF (T .LT. TINY) GO TO 150 R(KK) = T * R(KK) CALL DV7SCL(N, Q(1,K), ONE/T, Q(1,K)) IF (T/T1 .GE. REOTOL) GO TO 120 C C *** REORTHOGONALIZE COLUMN K *** C AK = ONE T2 = T * T2 WK = ZERO J = KK - K KM1 = K - 1 DO 110 I = 1, KM1 J = J + 1 T = DD7TPR(N, Q(1,I), Q(1,K)) WK = WK + T*T R(J) = R(J) + T*R(KK) 110 CALL DV2AXY(N, Q(1,K), -T, Q(1,I), Q(1,K)) T1 = ONE GO TO 80 C C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q *** C 120 IF (K .GE. P) GO TO 999 J = KK + K II = KK DO 130 I = KP1, P II = II + I T = DD7TPR(N, Q(1,K), Q(1,I)) R(J) = T J = J + I CALL DV2AXY(N, Q(1,I), -T, Q(1,K), Q(1,I)) T1 = R(II) IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2 130 CONTINUE 140 CONTINUE C C *** SINGULAR Q *** C 150 IERR = K KM1 = K - 1 J = KK DO 160 I = K, P CALL DV7SCP(I-KM1, R(J), ZERO) J = J + I 160 CONTINUE C 999 RETURN C *** LAST CARD OF DQ7RGS FOLLOWS *** END SUBROUTINE DQ7RSH(K, P, HAVQTR, QTR, R, W) C C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY *** C LOGICAL HAVQTR INTEGER K, P DOUBLE PRECISION QTR(P), R(1), W(P) C DIMSNSION R(P*(P+1)/2) C DOUBLE PRECISION DH2RFG EXTERNAL DH2RFA, DH2RFG,DV7CPY C C *** LOCAL VARIABLES *** C INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1 DOUBLE PRECISION A, B, T, WJ, X, Y, Z, ZERO C DATA ZERO/0.0D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (K .GE. P) GO TO 999 KM1 = K - 1 K1 = K * KM1 / 2 CALL DV7CPY(K, W, R(K1+1)) WJ = W(K) PM1 = P - 1 J1 = K1 + KM1 DO 50 J = K, PM1 JM1 = J - 1 JP1 = J + 1 IF (JM1 .GT. 0) CALL DV7CPY(JM1, R(K1+1), R(J1+2)) J1 = J1 + JP1 K1 = K1 + J A = R(J1) B = R(J1+1) IF (B .NE. ZERO) GO TO 10 R(K1) = A X = ZERO Z = ZERO GO TO 40 10 R(K1) = DH2RFG(A, B, X, Y, Z) IF (J .EQ. PM1) GO TO 30 I1 = J1 DO 20 I = JP1, PM1 I1 = I1 + I CALL DH2RFA(1, R(I1), R(I1+1), X, Y, Z) 20 CONTINUE 30 IF (HAVQTR) CALL DH2RFA(1, QTR(J), QTR(JP1), X, Y, Z) 40 T = X * WJ W(J) = WJ + T WJ = T * Z 50 CONTINUE W(P) = WJ CALL DV7CPY(P, R(K1+1), W) 999 RETURN END DOUBLE PRECISION FUNCTION DR7MDC(K) C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C INTEGER K C C *** THE CONSTANT RETURNED DEPENDS ON K... C C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS. C *** K = 2... SQUARE ROOT OF ETA. C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1. C *** K = 4... SQUARE ROOT OF MACHEP. C *** K = 5... SQUARE ROOT OF BIG (SEE K = 6). C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS. C DOUBLE PRECISION BIG, ETA, MACHEP C/+ DOUBLE PRECISION DSQRT C/ C DOUBLE PRECISION D1MACH, ZERO EXTERNAL D1MACH DATA BIG/0.D+0/, ETA/0.D+0/, MACHEP/0.D+0/, ZERO/0.D+0/ IF (BIG .GT. ZERO) GO TO 1 BIG = D1MACH(2) ETA = D1MACH(1) MACHEP = D1MACH(4) 1 CONTINUE C C------------------------------- BODY -------------------------------- C GO TO (10, 20, 30, 40, 50, 60), K C 10 DR7MDC = ETA GO TO 999 C 20 DR7MDC = DSQRT(256.D+0*ETA)/16.D+0 GO TO 999 C 30 DR7MDC = MACHEP GO TO 999 C 40 DR7MDC = DSQRT(MACHEP) GO TO 999 C 50 DR7MDC = DSQRT(BIG/256.D+0)*16.D+0 GO TO 999 C 60 DR7MDC = BIG C 999 RETURN C *** LAST CARD OF DR7MDC FOLLOWS *** END SUBROUTINE DR7TVM(N, P, Y, D, U, X) C C *** SET Y TO R*X, WHERE R IS THE UPPER TRIANGULAR MATRIX WHOSE C *** DIAGONAL IS IN D AND WHOSE STRICT UPPER TRIANGLE IS IN U. C C *** X AND Y MAY SHARE STORAGE. C INTEGER N, P DOUBLE PRECISION Y(P), D(P), U(N,P), X(P) C DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR C C *** LOCAL VARIABLES *** C INTEGER I, II, PL, PP1 DOUBLE PRECISION T C C *** BODY *** C PL = MIN0(N, P) PP1 = PL + 1 DO 10 II = 1, PL I = PP1 - II T = X(I) * D(I) IF (I .GT. 1) T = T + DD7TPR(I-1, U(1,I), X) Y(I) = T 10 CONTINUE 999 RETURN C *** LAST LINE OF DR7TVM FOLLOWS *** END DOUBLE PRECISION FUNCTION DRLDST(P, D, X, X0) C C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 *** C *** NL2SOL VERSION 2.2 *** C INTEGER P DOUBLE PRECISION D(P), X(P), X0(P) C INTEGER I DOUBLE PRECISION EMAX, T, XMAX, ZERO C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C C *** BODY *** C EMAX = ZERO XMAX = ZERO DO 10 I = 1, P T = DABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * (DABS(X(I)) + DABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE DRLDST = ZERO IF (XMAX .GT. ZERO) DRLDST = EMAX / XMAX 999 RETURN C *** LAST CARD OF DRLDST FOLLOWS *** END SUBROUTINE DRMNF(D, FX, IV, LIV, LV, N, V, X) C C *** ITERATION DRIVER FOR DMNF... C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION D(N), FX, X(N), V(LV) C DIMENSION V(77 + N*(N+17)/2) C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNG IN AN ATTEMPT C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR DRMNF ARE THE SAME AS THOSE FOR DMNG C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE C GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNF CALLS DS7GRD, C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1. C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD C (AND IS NOT DESCRIBED IN DMNG). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR DMNF THAN FOR DMNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (AUGUST 1982). C C---------------------------- DECLARATIONS --------------------------- C DOUBLE PRECISION DD7TPR EXTERNAL DIVSET, DD7TPR, DS7GRD, DRMNG, DV7SCP C C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DS7GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION. C DRMNG.... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNG ALGORITHM. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C INTEGER ALPHA, G1, I, IV1, J, K, W DOUBLE PRECISION ZERO C C *** SUBSCRIPTS FOR IV *** C INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, NITER, SGIRC, TOOBIG, 1 VNEED C C/6 C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/, C 1 NITER/31/, SGIRC/57/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30, 1 NITER=31, SGIRC=57, TOOBIG=2, VNEED=4) C/ C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IV1 = IV(1) IF (IV1 .EQ. 1) GO TO 10 IF (IV1 .EQ. 2) GO TO 50 IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*N + 6 IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) C 20 CALL DRMNG(D, FX, V(G1), IV, LIV, LV, N, V, X) IF (IV(1) - 2) 999, 30, 70 C C *** COMPUTE GRADIENT *** C 30 IF (IV(NITER) .EQ. 0) CALL DV7SCP(N, V(G1), ZERO) J = IV(LMAT) K = G1 - N DO 40 I = 1, N V(K) = DD7TPR(I, V(J), V(J)) K = K + 1 J = J + I 40 CONTINUE C *** UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNG *** IV(NGCALL) = IV(NGCALL) - 1 C *** STORE RETURN CODE FROM DS7GRD IN IV(SGIRC) *** IV(SGIRC) = 0 C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... *** FX = V(F) GO TO 60 C C *** GRADIENT LOOP *** C 50 IF (IV(TOOBIG) .NE. 0) GO TO 10 C 60 G1 = IV(G) ALPHA = G1 - N W = ALPHA - 6 CALL DS7GRD(V(ALPHA), D, V(ETA0), FX, V(G1), IV(SGIRC), N, V(W),X) IF (IV(SGIRC) .EQ. 0) GO TO 10 IV(NGCALL) = IV(NGCALL) + 1 GO TO 999 C 70 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) + N + 6 IV(NEXTV) = IV(G) + N IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF DRMNF FOLLOWS *** END SUBROUTINE DRMNFB(B, D, FX, IV, LIV, LV, P, V, X) C C *** ITERATION DRIVER FOR DMNF... C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER LIV, LV, P INTEGER IV(LIV) DOUBLE PRECISION B(2,P), D(P), FX, X(P), V(LV) C DIMENSION IV(59 + P), V(77 + P*(P+23)/2) C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNGB IN AN ATTEMPT C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR DRMNFB ARE THE SAME AS THOSE FOR DMNG C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE C GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNFB CALLS DS3GRD, C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1. C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD C (AND IS NOT DESCRIBED IN DMNG). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR DMNF THAN FOR DMNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (AUGUST 1982). C C---------------------------- DECLARATIONS --------------------------- C DOUBLE PRECISION DD7TPR EXTERNAL DIVSET, DD7TPR, DS3GRD, DRMNGB, DV7SCP C C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DS3GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION. C DRMNGB... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNGB ALGORITHM. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C INTEGER ALPHA, ALPHA0, G1, I, IPI, IV1, J, K, W DOUBLE PRECISION ZERO C C *** SUBSCRIPTS FOR IV *** C INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, 1 NITER, PERM, SGIRC, TOOBIG, VNEED C C/6 C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/, C 1 NITER/31/, PERM/58/, SGIRC/57/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30, 1 NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4) C/ C/6 C DATA ZERO/0.D+0/ C/7 PARAMETER (ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IV1 = IV(1) IF (IV1 .EQ. 1) GO TO 10 IF (IV1 .EQ. 2) GO TO 50 IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*P + 6 IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) C 20 CALL DRMNGB(B, D, FX, V(G1), IV, LIV, LV, P, V, X) IF (IV(1) - 2) 999, 30, 80 C C *** COMPUTE GRADIENT *** C 30 IF (IV(NITER) .EQ. 0) CALL DV7SCP(P, V(G1), ZERO) J = IV(LMAT) ALPHA0 = G1 - P - 1 IPI = IV(PERM) DO 40 I = 1, P K = ALPHA0 + IV(IPI) V(K) = DD7TPR(I, V(J), V(J)) IPI = IPI + 1 J = J + I 40 CONTINUE C *** UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNGB *** IV(NGCALL) = IV(NGCALL) - 1 C *** STORE RETURN CODE FROM DS3GRD IN IV(SGIRC) *** IV(SGIRC) = 0 C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... *** FX = V(F) GO TO 60 C C *** GRADIENT LOOP *** C 50 IF (IV(TOOBIG) .NE. 0) GO TO 10 C 60 G1 = IV(G) ALPHA = G1 - P W = ALPHA - 6 CALL DS3GRD(V(ALPHA), B, D, V(ETA0), FX, V(G1), IV(SGIRC), P, 1 V(W), X) I = IV(SGIRC) IF (I .EQ. 0) GO TO 10 IF (I .LE. P) GO TO 70 IV(TOOBIG) = 1 GO TO 10 C 70 IV(NGCALL) = IV(NGCALL) + 1 GO TO 999 C 80 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) + P + 6 IV(NEXTV) = IV(G) + P IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF DRMNFB FOLLOWS *** END SUBROUTINE DRMNG(D, FX, G, IV, LIV, LV, N, V, X) C C *** CARRY OUT DMNG (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING C *** DOUBLE-DOGLEG/BFGS STEPS. C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION D(N), FX, G(N), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV (AT LEAST 60). C LV... LENGTH OF V (AT LEAST 71 + N*(N+13)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO DMNG (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT DMNG USES FOR STORING G IS NOT NEEDED). C MOREOVER, COMPARED WITH DMNG, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM DMNG (AND DMNF), IS NOT REFERENCED BY C DRMNG OR THE SUBROUTINES IT CALLS. C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN DRMNG IS CALLED C WITH IV(1) = 12, 13, OR 14. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL DRMNG AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE DRMNG TO IG- C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT C DMNG PASSES TO CALCF (FOR POSSIBLE USE BY CALCG) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR C OF F AT X, AND CALL DRMNG AGAIN, HAVING CHANGED NONE OF C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT DMNG PASSES C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE C EVALUATED, THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN C WHICH CASE DRMNG WILL RETURN WITH IV(1) = 65. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C (SEE DMNG FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DUMMY, G01, I, K, L, LSTGST, NWTST1, RSTRST, STEP1, 1 TEMP1, W, X01, Z DOUBLE PRECISION T C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM EXTERNAL DA7SST,DD7DOG,DIVSET, DD7TPR,DITSUM, DL7ITV, DL7IVM, 1 DL7TVM, DL7UPD,DL7VML,DPARCK, DRLDST, STOPX,DV2AXY, 2 DV7CPY, DV7SCP, DV7VMP, DV2NRM, DW7ZBF C C DA7SST.... ASSESSES CANDIDATE STEP. C DD7DOG.... COMPUTES DOUBLE-DOGLEG (CANDIDATE) STEP. C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DL7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C DL7IVM... MULTIPLIES INVERSE OF LOWER TRIANGLE TIMES VECTOR. C DL7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION. C DL7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR. C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE). C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C DW7ZBF... COMPUTES W AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DST0, F, F0, FDIF, 1 GTHG, GTSTEP, G0, INCFAC, INITH, IRC, KAGQT, LMAT, LMAX0, 2 LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, 3 NGCALL, NITER, NREDUC, NWTSTP, PREDUC, RADFAC, RADINC, 4 RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, TOOBIG, 5 TUNER4, TUNER5, VNEED, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, DG/37/, G0/48/, INITH/25/, IRC/29/, KAGQT/33/, C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NFCALL/6/, C 2 NFGCAL/7/, NGCALL/30/, NITER/31/, NWTSTP/34/, RADINC/8/, C 3 RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/, C 4 VNEED/4/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, G0=48, INITH=25, IRC=29, KAGQT=33, 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NFCALL=6, 2 NFGCAL=7, NGCALL=30, NITER=31, NWTSTP=34, RADINC=8, 3 RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, 4 VNEED=4, XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DST0/3/, F/10/, F0/13/, C 1 FDIF/11/, GTHG/44/, GTSTEP/4/, INCFAC/23/, LMAT/42/, C 2 LMAX0/35/, LMAXS/36/, NEXTV/47/, NREDUC/6/, PREDUC/7/, C 3 RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/, TUNER4/29/, C 4 TUNER5/30/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DST0=3, F=10, F0=13, 1 FDIF=11, GTHG=44, GTSTEP=4, INCFAC=23, LMAT=42, 2 LMAX0=35, LMAXS=36, NEXTV=47, NREDUC=6, PREDUC=7, 3 RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, TUNER4=29, 4 TUNER5=30) C/ C C/6 C DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, C 1 ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, 1 ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13) 1 IV(VNEED) = IV(VNEED) + N*(N+13)/2 CALL DPARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (190, 190, 190, 190, 190, 190, 120, 90, 120, 10, 10, 20), I C C *** STORAGE ALLOCATION *** C 10 L = IV(LMAT) IV(X0) = L + N*(N+1)/2 IV(STEP) = IV(X0) + N IV(STLSTG) = IV(STEP) + N IV(G0) = IV(STLSTG) + N IV(NWTSTP) = IV(G0) + N IV(DG) = IV(NWTSTP) + N IV(NEXTV) = IV(DG) + N IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 V(RAD0) = ZERO IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT)) IF (IV(INITH) .NE. 1) GO TO 40 C C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 *** C L = IV(LMAT) CALL DV7SCP(N*(N+1)/2, V(L), ZERO) K = L - 1 DO 30 I = 1, N K = K + I T = D(I) IF (T .LE. ZERO) T = ONE V(K) = T 30 CONTINUE C C *** COMPUTE INITIAL FUNCTION VALUE *** C 40 IV(1) = 1 GO TO 999 C 50 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 190 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 350 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 350 C 70 DG1 = IV(DG) CALL DV7VMP(N, V(DG1), G, D, -1) V(DGNORM) = DV2NRM(N, V(DG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 340 IF (IV(MODE) .EQ. 0) GO TO 300 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 80 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) 90 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 100 IV(1) = 10 GO TO 350 C C *** UPDATE RADIUS *** C 100 IV(NITER) = K + 1 IF (K .GT. 0) V(RADIUS) = V(RADFAC) * V(DSTNRM) C C *** INITIALIZE FOR START OF NEXT ITERATION *** C G01 = IV(G0) X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0, G TO G0 *** C CALL DV7CPY(N, V(X01), X) CALL DV7CPY(N, V(G01), G) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 110 IF (.NOT. STOPX(DUMMY)) GO TO 130 IV(1) = 11 GO TO 140 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 120 IF (V(F) .GE. V(F0)) GO TO 130 V(RADFAC) = ONE K = IV(NITER) GO TO 100 C 130 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 150 IV(1) = 9 140 IF (V(F) .GE. V(F0)) GO TO 350 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 290 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 150 STEP1 = IV(STEP) DG1 = IV(DG) NWTST1 = IV(NWTSTP) IF (IV(KAGQT) .GE. 0) GO TO 160 L = IV(LMAT) CALL DL7IVM(N, V(NWTST1), V(L), G) V(NREDUC) = HALF * DD7TPR(N, V(NWTST1), V(NWTST1)) CALL DL7ITV(N, V(NWTST1), V(L), V(NWTST1)) CALL DV7VMP(N, V(STEP1), V(NWTST1), D, 1) V(DST0) = DV2NRM(N, V(STEP1)) CALL DV7VMP(N, V(DG1), V(DG1), D, -1) CALL DL7TVM(N, V(STEP1), V(L), V(DG1)) V(GTHG) = DV2NRM(N, V(STEP1)) IV(KAGQT) = 0 160 CALL DD7DOG(V(DG1), LV, N, V(NWTST1), V(STEP1), V) IF (IV(IRC) .NE. 6) GO TO 170 IF (IV(RESTOR) .NE. 2) GO TO 190 RSTRST = 2 GO TO 200 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 170 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 190 IF (IV(IRC) .NE. 5) GO TO 180 IF (V(RADFAC) .LE. ONE) GO TO 180 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 180 IF (IV(RESTOR) .NE. 2) GO TO 190 RSTRST = 0 GO TO 200 C C *** COMPUTE F(X0 + STEP) *** C 180 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 190 RSTRST = 3 200 X01 = IV(X0) V(RELDX) = DRLDST(N, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (240, 210, 220, 230), I 210 CALL DV7CPY(N, X, V(X01)) GO TO 240 220 CALL DV7CPY(N, V(LSTGST), V(STEP1)) GO TO 240 230 CALL DV7CPY(N, V(STEP1), V(LSTGST)) CALL DV2AXY(N, X, ONE, V(STEP1), V(X01)) V(RELDX) = DRLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 240 K = IV(IRC) GO TO (250,280,280,280,250,260,270,270,270,270,270,270,330,300), K C C *** RECOMPUTE STEP WITH CHANGED RADIUS *** C 250 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 110 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 260 V(RADIUS) = V(LMAXS) GO TO 150 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 270 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 340 IF (IV(XIRC) .EQ. 14) GO TO 340 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 280 IF (IV(IRC) .NE. 3) GO TO 290 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C L = IV(LMAT) CALL DL7TVM(N, V(TEMP1), V(L), V(STEP1)) CALL DL7VML(N, V(TEMP1), V(L), V(TEMP1)) C C *** COMPUTE GRADIENT *** C 290 IV(NGCALL) = IV(NGCALL) + 1 IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 300 G01 = IV(G0) CALL DV2AXY(N, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) IF (IV(IRC) .NE. 3) GO TO 320 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C CALL DV2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1)) CALL DV7VMP(N, V(TEMP1), V(TEMP1), D, -1) C C *** DO GRADIENT TESTS *** C IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) 1 GO TO 310 IF (DD7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 320 310 V(RADFAC) = V(INCFAC) C C *** UPDATE H, LOOP *** C 320 W = IV(NWTSTP) Z = IV(X0) L = IV(LMAT) CALL DW7ZBF(V(L), N, V(STEP1), V(W), V(G01), V(Z)) C C ** USE THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH.. CALL DL7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W), V(Z)) IV(1) = 2 GO TO 80 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 330 IV(1) = 64 GO TO 350 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 340 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 350 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) C 999 RETURN C C *** LAST LINE OF DRMNG FOLLOWS *** END SUBROUTINE DRMNGB(B, D, FX, G, IV, LIV, LV, N, V, X) C C *** CARRY OUT DMNGB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS, C *** USING DOUBLE-DOGLEG/BFGS STEPS. C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION B(2,N), D(N), FX, G(N), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X. C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV (AT LEAST 59) + N. C LV... LENGTH OF V (AT LEAST 71 + N*(N+19)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO DMNGB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT DMNGB USES FOR STORING G IS NOT NEEDED). C MOREOVER, COMPARED WITH DMNGB, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM DMNGB (AND SMSNOB), IS NOT REFERENCED BY C DRMNGB OR THE SUBROUTINES IT CALLS. C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN DRMNGB IS CALLED C WITH IV(1) = 12, 13, OR 14. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL DRMNGB AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE DRMNGB TO IG- C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT C DMNGB PASSES TO CALCF (FOR POSSIBLE USE BY CALCG) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR C OF F AT X, AND CALL DRMNGB AGAIN, HAVING CHANGED NONE OF C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT DMNGB PASSES C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE C EVALUATED, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN C WHICH CASE DRMNGB WILL RETURN WITH IV(1) = 65. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C (SEE DMNG FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DSTEP1, DUMMY, G01, I, I1, IPI, IPN, J, K, L, LSTGST, 1 N1, NP1, NWTST1, RSTRST, STEP1, TEMP0, TEMP1, TD1, TG1, 2 W1, X01, Z DOUBLE PRECISION GI, T, XI C C *** CONSTANTS *** C DOUBLE PRECISION NEGONE, ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM EXTERNAL DA7SST, DD7DGB,DIVSET, DD7TPR, I7SHFT,DITSUM, DL7TVM, 1 DL7UPD,DL7VML,DPARCK, DQ7RSH, DRLDST, STOPX, DV2NRM, 2 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP, DW7ZBF C C DA7SST.... ASSESSES CANDIDATE STEP. C DD7DGB... COMPUTES SIMPLY BOUNDED DOUBLE-DOGLEG (CANDIDATE) STEP. C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C I7SHFT... CYCLICALLLY SHIFTS AN ARRAY OF INTEGERS. C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DL7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION. C DL7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR. C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C DQ7RSH... CYCLICALLY SHIFTS CHOLESKY FACTOR. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7IPR... CYCLICALLY SHIFTS A FLOATING-POINT ARRAY. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE). C DW7ZBF... COMPUTES W AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, F, F0, FDIF, 1 GTSTEP, INCFAC, INITH, IRC, IVNEED, KAGQT, LMAT, 2 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NC, NEXTIV, 3 NEXTV, NFCALL, NFGCAL, NGCALL, NITER, NWTSTP, PERM, 4 PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, 4 STGLIM, STLSTG, TOOBIG, TUNER4, TUNER5, VNEED, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT NC IS STORED IN IV(G0)) *** C C/6 C DATA CNVCOD/55/, DG/37/, INITH/25/, IRC/29/, IVNEED/3/, KAGQT/33/, C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NC/48/, C 2 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, C 3 NITER/31/, NWTSTP/34/, PERM/58/, RADINC/8/, RESTOR/9/, C 4 STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, INITH=25, IRC=29, IVNEED=3, KAGQT=33, 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NC=48, 2 NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, 3 NITER=31, NWTSTP=34, PERM=58, RADINC=8, RESTOR=9, 4 STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, XIRC=13, 5 X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, F/10/, F0/13/, FDIF/11/, C 1 GTSTEP/4/, INCFAC/23/, LMAT/42/, LMAX0/35/, LMAXS/36/, C 2 PREDUC/7/, RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/, C 3 TUNER4/29/, TUNER5/30/, VNEED/4/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, F=10, F0=13, FDIF=11, 1 GTSTEP=4, INCFAC=23, LMAT=42, LMAX0=35, LMAXS=36, 2 PREDUC=7, RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, 3 TUNER4=29, TUNER5=30, VNEED=4) C/ C C/6 C DATA NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, ZERO/0.D+0/ C/7 PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 70 IF (I .EQ. 2) GO TO 80 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IF (IV(1) .LT. 12) GO TO 10 IF (IV(1) .GT. 13) GO TO 10 IV(VNEED) = IV(VNEED) + N*(N+19)/2 IV(IVNEED) = IV(IVNEED) + N 10 CALL DPARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (250, 250, 250, 250, 250, 250, 190, 150, 190, 20, 20, 30), I C C *** STORAGE ALLOCATION *** C 20 L = IV(LMAT) IV(X0) = L + N*(N+1)/2 IV(STEP) = IV(X0) + 2*N IV(STLSTG) = IV(STEP) + 2*N IV(NWTSTP) = IV(STLSTG) + N IV(DG) = IV(NWTSTP) + 2*N IV(NEXTV) = IV(DG) + 2*N IV(NEXTIV) = IV(PERM) + N IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 IV(NC) = N V(RAD0) = ZERO C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(PERM) DO 40 I = 1, N IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 410 40 CONTINUE C IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT)) IF (IV(INITH) .NE. 1) GO TO 60 C C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 *** C L = IV(LMAT) CALL DV7SCP(N*(N+1)/2, V(L), ZERO) K = L - 1 DO 50 I = 1, N K = K + I T = D(I) IF (T .LE. ZERO) T = ONE V(K) = T 50 CONTINUE C C *** GET INITIAL FUNCTION VALUE *** C 60 IV(1) = 1 GO TO 440 C 70 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 250 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 430 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 80 IF (IV(TOOBIG) .EQ. 0) GO TO 90 IV(1) = 65 GO TO 430 C C *** CHOOSE INITIAL PERMUTATION *** C 90 IPI = IV(PERM) IPN = IPI + N N1 = N NP1 = N + 1 L = IV(LMAT) W1 = IV(NWTSTP) + N K = N - IV(NC) DO 120 I = 1, N IPN = IPN - 1 J = IV(IPN) IF (B(1,J) .GE. B(2,J)) GO TO 100 XI = X(J) GI = G(J) IF (XI .LE. B(1,J) .AND. GI .GT. ZERO) GO TO 100 IF (XI .GE. B(2,J) .AND. GI .LT. ZERO) GO TO 100 C *** DISALLOW CONVERGENCE IF X(J) HAS JUST BEEN FREED *** IF (I .LE. K) IV(CNVCOD) = 0 GO TO 120 100 I1 = NP1 - I IF (I1 .GE. N1) GO TO 110 CALL I7SHFT(N1, I1, IV(IPI)) CALL DQ7RSH(I1, N1, .FALSE., G, V(L), V(W1)) 110 N1 = N1 - 1 120 CONTINUE C IV(NC) = N1 V(DGNORM) = ZERO IF (N1 .LE. 0) GO TO 130 DG1 = IV(DG) CALL DV7VMP(N, V(DG1), G, D, -1) CALL DV7IPR(N, IV(IPI), V(DG1)) V(DGNORM) = DV2NRM(N1, V(DG1)) 130 IF (IV(CNVCOD) .NE. 0) GO TO 420 IF (IV(MODE) .EQ. 0) GO TO 370 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 140 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) 150 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 160 IV(1) = 10 GO TO 430 C C *** UPDATE RADIUS *** C 160 IV(NITER) = K + 1 IF (K .EQ. 0) GO TO 170 T = V(RADFAC) * V(DSTNRM) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 170 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0 *** C CALL DV7CPY(N, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 180 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 210 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 190 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 160 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220 IV(1) = 9 210 IF (V(F) .GE. V(F0)) GO TO 430 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 360 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 220 STEP1 = IV(STEP) DG1 = IV(DG) NWTST1 = IV(NWTSTP) W1 = NWTST1 + N DSTEP1 = STEP1 + N IPI = IV(PERM) L = IV(LMAT) TG1 = DG1 + N X01 = IV(X0) TD1 = X01 + N CALL DD7DGB(B, D, V(DG1), V(DSTEP1), G, IV(IPI), IV(KAGQT), 1 V(L), LV, N, IV(NC), V(NWTST1), V(STEP1), V(TD1), 2 V(TG1), V, V(W1), V(X01)) IF (IV(IRC) .NE. 6) GO TO 230 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 2 GO TO 260 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 230 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 250 IF (IV(IRC) .NE. 5) GO TO 240 IF (V(RADFAC) .LE. ONE) GO TO 240 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 0 GO TO 260 C C *** COMPUTE F(X0 + STEP) *** C 240 CALL DV2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 440 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 250 RSTRST = 3 260 X01 = IV(X0) V(RELDX) = DRLDST(N, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (300, 270, 280, 290), I 270 CALL DV7CPY(N, X, V(X01)) GO TO 300 280 CALL DV7CPY(N, V(LSTGST), X) GO TO 300 290 CALL DV7CPY(N, X, V(LSTGST)) CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X) V(RELDX) = DRLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 300 K = IV(IRC) GO TO (310,340,340,340,310,320,330,330,330,330,330,330,400,370), K C C *** RECOMPUTE STEP WITH CHANGED RADIUS *** C 310 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 180 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 320 V(RADIUS) = V(LMAXS) GO TO 220 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 330 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 420 IF (IV(XIRC) .EQ. 14) GO TO 420 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 340 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X) IF (IV(IRC) .NE. 3) GO TO 360 C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C C *** USE X0 AS TEMPORARY... C IPI = IV(PERM) CALL DV7CPY(N, V(X01), V(STEP1)) CALL DV7IPR(N, IV(IPI), V(X01)) L = IV(LMAT) CALL DL7TVM(N, V(X01), V(L), V(X01)) CALL DL7VML(N, V(X01), V(L), V(X01)) C C *** UNPERMUTE X0 INTO TEMP1 *** C TEMP1 = IV(STLSTG) TEMP0 = TEMP1 - 1 DO 350 I = 1, N J = IV(IPI) IPI = IPI + 1 K = TEMP0 + J V(K) = V(X01) X01 = X01 + 1 350 CONTINUE C C *** SAVE OLD GRADIENT, COMPUTE NEW ONE *** C 360 G01 = IV(NWTSTP) + N CALL DV7CPY(N, V(G01), G) IV(NGCALL) = IV(NGCALL) + 1 IV(TOOBIG) = 0 IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 370 G01 = IV(NWTSTP) + N CALL DV2AXY(N, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) IF (IV(IRC) .NE. 3) GO TO 390 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C CALL DV2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1)) CALL DV7VMP(N, V(TEMP1), V(TEMP1), D, -1) C C *** DO GRADIENT TESTS *** C IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) 1 GO TO 380 IF (DD7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 390 380 V(RADFAC) = V(INCFAC) C C *** UPDATE H, LOOP *** C 390 W1 = IV(NWTSTP) Z = IV(X0) L = IV(LMAT) IPI = IV(PERM) CALL DV7IPR(N, IV(IPI), V(STEP1)) CALL DV7IPR(N, IV(IPI), V(G01)) CALL DW7ZBF(V(L), N, V(STEP1), V(W1), V(G01), V(Z)) C C ** USE THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH.. CALL DL7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W1), 1 V(Z)) IV(1) = 2 GO TO 140 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 400 IV(1) = 64 GO TO 430 C C *** INCONSISTENT B *** C 410 IV(1) = 82 GO TO 430 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 420 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 430 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) GO TO 999 C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 440 DO 450 I = 1, N IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 450 CONTINUE C 999 RETURN C C *** LAST CARD OF DRMNGB FOLLOWS *** END SUBROUTINE DRMNH(D, FX, G, H, IV, LH, LIV, LV, N, V, X) C C *** CARRY OUT DMNH (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING C *** HESSIAN MATRIX PROVIDED BY THE CALLER. C C *** PARAMETER DECLARATIONS *** C INTEGER LH, LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION D(N), FX, G(N), H(LH), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE. C IV... INTEGER VALUE ARRAY. C LH... LENGTH OF H = P*(P+1)/2. C LIV.. LENGTH OF IV (AT LEAST 60). C LV... LENGTH OF V (AT LEAST 78 + N*(N+21)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO DMNH (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT DMNH USES FOR STORING G AND H IS NOT NEEDED). C MOREOVER, COMPARED WITH DMNH, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM DMNH, IS NOT REFERENCED BY DRMNH OR THE C SUBROUTINES IT CALLS. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL DRMNH AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE C DRMNH TO IGNORE FX AND TRY A SMALLER STEP. THE PARA- C METER NF THAT DMNH PASSES TO CALCF (FOR POSSIBLE USE BY C CALCGH) IS A COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F C AT X, AND CALL DRMNH AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D. C THE PARAMETER NF THAT DMNH PASSES TO CALCG IS C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED, C THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN WHICH CASE C DRMNH WILL RETURN WITH IV(1) = 65. C NOTE -- DRMNH OVERWRITES H WITH THE LOWER TRIANGLE C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C (SEE DMNG AND DMNH FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DUMMY, I, J, K, L, LSTGST, NN1O2, RSTRST, STEP1, 1 TEMP1, W1, X01 DOUBLE PRECISION T C C *** CONSTANTS *** C DOUBLE PRECISION ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM EXTERNAL DA7SST,DIVSET, DD7TPR,DD7DUP,DG7QTS,DITSUM,DPARCK, 1 DRLDST, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP, DV2NRM C C DA7SST.... ASSESSES CANDIDATE STEP. C DIVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DD7DUP.... UPDATES SCALE VECTOR D. C DG7QTS.... COMPUTES OPTIMALLY LOCALLY CONSTRAINED STEP. C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C DS7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER C TRIANGLE OF THE MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, 1 DTYPE, D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IRC, KAGQT, 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, 3 NFCALL, NFGCAL, NGCALL, NITER, PHMXFC, PREDUC, RADFAC, 4 RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, 5 STPPAR, TOOBIG, TUNER4, TUNER5, VNEED, W, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, KAGQT/33/, C 1 LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NITER/31/, C 3 RADINC/8/, RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/, C 4 TOOBIG/2/, VNEED/4/, W/34/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, KAGQT=33, 1 LMAT=42, MODE=35, MODEL=5, MXFCAL=17, MXITER=18, 2 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NITER=31, 3 RADINC=8, RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, 4 TOOBIG=2, VNEED=4, W=34, XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/, C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40, 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35, 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30) C/ C C/6 C DATA ONE/1.D+0/, ONEP2/1.2D+0/, ZERO/0.D+0/ C/7 PARAMETER (ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 30 IF (I .EQ. 2) GO TO 40 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13) 1 IV(VNEED) = IV(VNEED) + N*(N+21)/2 + 7 CALL DPARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 NN1O2 = N * (N + 1) / 2 IF (LH .GE. NN1O2) GO TO (220,220,220,220,220,220,160,120,160, 1 10,10,20), I IV(1) = 66 GO TO 400 C C *** STORAGE ALLOCATION *** C 10 IV(DTOL) = IV(LMAT) + NN1O2 IV(X0) = IV(DTOL) + 2*N IV(STEP) = IV(X0) + N IV(STLSTG) = IV(STEP) + N IV(DG) = IV(STLSTG) + N IV(W) = IV(DG) + N IV(NEXTV) = IV(W) + 4*N + 7 IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 V(RAD0) = ZERO V(STPPAR) = ZERO IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT)) K = IV(DTOL) IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(DTINIT)) K = K + N IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(D0INIT)) IV(1) = 1 GO TO 999 C 30 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 220 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 400 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 40 IF (IV(TOOBIG) .EQ. 0) GO TO 50 IV(1) = 65 GO TO 400 C C *** UPDATE THE SCALE VECTOR D *** C 50 DG1 = IV(DG) IF (IV(DTYPE) .LE. 0) GO TO 70 K = DG1 J = 0 DO 60 I = 1, N J = J + I V(K) = H(J) K = K + 1 60 CONTINUE CALL DD7DUP(D, V(DG1), IV, LIV, LV, N, V) C C *** COMPUTE SCALED GRADIENT AND ITS NORM *** C 70 DG1 = IV(DG) K = DG1 DO 80 I = 1, N V(K) = G(I) / D(I) K = K + 1 80 CONTINUE V(DGNORM) = DV2NRM(N, V(DG1)) C C *** COMPUTE SCALED HESSIAN *** C K = 1 DO 100 I = 1, N T = ONE / D(I) DO 90 J = 1, I H(K) = T * H(K) / D(J) K = K + 1 90 CONTINUE 100 CONTINUE C IF (IV(CNVCOD) .NE. 0) GO TO 390 IF (IV(MODE) .EQ. 0) GO TO 350 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 110 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) 120 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 130 IV(1) = 10 GO TO 400 C 130 IV(NITER) = K + 1 C C *** INITIALIZE FOR START OF NEXT ITERATION *** C DG1 = IV(DG) X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0 *** C CALL DV7CPY(N, V(X01), X) C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 150 STEP1 = IV(STEP) K = STEP1 DO 140 I = 1, N V(K) = D(I) * V(K) K = K + 1 140 CONTINUE V(RADIUS) = V(RADFAC) * DV2NRM(N, V(STEP1)) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 150 IF (.NOT. STOPX(DUMMY)) GO TO 170 IV(1) = 11 GO TO 180 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 160 IF (V(F) .GE. V(F0)) GO TO 170 V(RADFAC) = ONE K = IV(NITER) GO TO 130 C 170 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 190 IV(1) = 9 180 IF (V(F) .GE. V(F0)) GO TO 400 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 340 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 190 STEP1 = IV(STEP) DG1 = IV(DG) L = IV(LMAT) W1 = IV(W) CALL DG7QTS(D, V(DG1), H, IV(KAGQT), V(L), N, V(STEP1), V, V(W1)) IF (IV(IRC) .NE. 6) GO TO 200 IF (IV(RESTOR) .NE. 2) GO TO 220 RSTRST = 2 GO TO 230 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 200 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 220 IF (IV(IRC) .NE. 5) GO TO 210 IF (V(RADFAC) .LE. ONE) GO TO 210 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 210 IF (IV(RESTOR) .NE. 2) GO TO 220 RSTRST = 0 GO TO 230 C C *** COMPUTE F(X0 + STEP) *** C 210 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 220 RSTRST = 3 230 X01 = IV(X0) V(RELDX) = DRLDST(N, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (270, 240, 250, 260), I 240 CALL DV7CPY(N, X, V(X01)) GO TO 270 250 CALL DV7CPY(N, V(LSTGST), V(STEP1)) GO TO 270 260 CALL DV7CPY(N, V(STEP1), V(LSTGST)) CALL DV2AXY(N, X, ONE, V(STEP1), V(X01)) V(RELDX) = DRLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 270 K = IV(IRC) GO TO (280,310,310,310,280,290,300,300,300,300,300,300,380,350), K C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 280 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 150 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 290 V(RADIUS) = V(LMAXS) GO TO 190 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 300 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 390 IF (IV(XIRC) .EQ. 14) GO TO 390 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 310 IF (IV(IRC) .NE. 3) GO TO 340 TEMP1 = LSTGST C C *** PREPARE FOR GRADIENT TESTS *** C *** SET TEMP1 = HESSIAN * STEP + G(X0) C *** = DIAG(D) * (H * STEP + G(X0)) C C USE X0 VECTOR AS TEMPORARY. K = X01 DO 320 I = 1, N V(K) = D(I) * V(STEP1) K = K + 1 STEP1 = STEP1 + 1 320 CONTINUE CALL DS7LVM(N, V(TEMP1), H, V(X01)) DO 330 I = 1, N V(TEMP1) = D(I) * V(TEMP1) + G(I) TEMP1 = TEMP1 + 1 330 CONTINUE C C *** COMPUTE GRADIENT AND HESSIAN *** C 340 IV(NGCALL) = IV(NGCALL) + 1 IV(TOOBIG) = 0 IV(1) = 2 GO TO 999 C 350 IV(1) = 2 IF (IV(IRC) .NE. 3) GO TO 110 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C TEMP1 = IV(STLSTG) STEP1 = IV(STEP) C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C K = TEMP1 DO 360 I = 1, N V(K) = (V(K) - G(I)) / D(I) K = K + 1 360 CONTINUE C C *** DO GRADIENT TESTS *** C IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 370 IF (DD7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 110 370 V(RADFAC) = V(INCFAC) GO TO 110 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 380 IV(1) = 64 GO TO 400 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 390 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 400 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) C 999 RETURN C C *** LAST CARD OF DRMNH FOLLOWS *** END SUBROUTINE DRMNHB(B, D, FX, G, H, IV, LH, LIV, LV, N, V, X) C C *** CARRY OUT DMNHB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS, C *** USING HESSIAN MATRIX PROVIDED BY THE CALLER. C C *** PARAMETER DECLARATIONS *** C INTEGER LH, LIV, LV, N INTEGER IV(LIV) DOUBLE PRECISION B(2,N), D(N), FX, G(N), H(LH), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE. C IV... INTEGER VALUE ARRAY. C LH... LENGTH OF H = P*(P+1)/2. C LIV.. LENGTH OF IV (AT LEAST 59 + 3*N). C LV... LENGTH OF V (AT LEAST 78 + N*(N+27)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO DMNHB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT DMNHB USES FOR STORING G AND H IS NOT NEEDED). C MOREOVER, COMPARED WITH DMNHB, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM DMNHB, IS NOT REFERENCED BY DRMNHB OR THE C SUBROUTINES IT CALLS. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL DRMNHB AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE C DRMNHB TO IGNORE FX AND TRY A SMALLER STEP. THE PARA- C METER NF THAT DMNH PASSES TO CALCF (FOR POSSIBLE USE BY C CALCGH) IS A COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F C AT X, AND CALL DRMNHB AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D. C THE PARAMETER NF THAT DMNHB PASSES TO CALCG IS C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED, C THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH CASE C DRMNHB WILL RETURN WITH IV(1) = 65. C NOTE -- DRMNHB OVERWRITES H WITH THE LOWER TRIANGLE C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER, SPRING 1983). C C (SEE DMNG AND DMNH FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DUMMY, I, IPI, IPIV2, IPN, J, K, L, LSTGST, NN1O2, 1 RSTRST, STEP0, STEP1, TD1, TEMP0, TEMP1, TG1, W1, X01, X11 DOUBLE PRECISION GI, T, XI C C *** CONSTANTS *** C DOUBLE PRECISION NEGONE, ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM EXTERNAL DA7SST,DIVSET, DD7TPR,DD7DUP, DG7QSB, I7PNVR,DITSUM, 1 DPARCK, DRLDST, DS7IPR, DS7LVM, STOPX, DV2NRM,DV2AXY, 2 DV7CPY, DV7IPR, DV7SCP, DV7VMP C C DA7SST.... ASSESSES CANDIDATE STEP. C DIVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DD7DUP.... UPDATES SCALE VECTOR D. C DG7QSB... COMPUTES APPROXIMATE OPTIMAL BOUNDED STEP. C I7PNVR... INVERTS PERMUTATION ARRAY. C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C DS7IPR... APPLIES PERMUTATION TO LOWER TRIANG. OF SYM. MATRIX. C DS7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER C TRIANGLE OF THE MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7IPR... APPLIES PERMUTATION TO VECTOR. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV7VMP... MULTIPLIES (OR DIVIDES) TWO VECTORS COMPONENTWISE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, DTYPE, 1 D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IVNEED, IRC, KAGQT, 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, N0, NC, 3 NEXTIV, NEXTV, NFCALL, NFGCAL, NGCALL, NITER, PERM, 4 PHMXFC, PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, 5 RESTOR, STEP, STGLIM, STPPAR, TOOBIG, TUNER4, TUNER5, 6 VNEED, W, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT NC AND N0 ARE STORED IN IV(G0) AND IV(STLSTG) RESP.) C C/6 C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, IVNEED/3/, C 1 KAGQT/33/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, C 2 MXITER/18/, N0/41/, NC/48/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, C 3 NFGCAL/7/, NGCALL/30/, NITER/31/, PERM/58/, RADINC/8/, C 4 RESTOR/9/, STEP/40/, STGLIM/11/, TOOBIG/2/, VNEED/4/, W/34/, C 5 XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, IVNEED=3, 1 KAGQT=33, LMAT=42, MODE=35, MODEL=5, MXFCAL=17, 2 MXITER=18, N0=41, NC=48, NEXTIV=46, NEXTV=47, NFCALL=6, 3 NFGCAL=7, NGCALL=30, NITER=31, PERM=58, RADINC=8, 4 RESTOR=9, STEP=40, STGLIM=11, TOOBIG=2, VNEED=4, W=34, 5 XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/, C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40, 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35, 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30) C/ C C/6 C DATA NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, ZERO/0.D+0/ C/7 PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V) IF (IV(1) .LT. 12) GO TO 10 IF (IV(1) .GT. 13) GO TO 10 IV(VNEED) = IV(VNEED) + N*(N+27)/2 + 7 IV(IVNEED) = IV(IVNEED) + 3*N 10 CALL DPARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 NN1O2 = N * (N + 1) / 2 IF (LH .GE. NN1O2) GO TO (250,250,250,250,250,250,190,150,190, 1 20,20,30), I IV(1) = 81 GO TO 440 C C *** STORAGE ALLOCATION *** C 20 IV(DTOL) = IV(LMAT) + NN1O2 IV(X0) = IV(DTOL) + 2*N IV(STEP) = IV(X0) + 2*N IV(DG) = IV(STEP) + 3*N IV(W) = IV(DG) + 2*N IV(NEXTV) = IV(W) + 4*N + 7 IV(NEXTIV) = IV(PERM) + 3*N IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 IV(NC) = N V(RAD0) = ZERO V(STPPAR) = ZERO IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT)) K = IV(DTOL) IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(DTINIT)) K = K + N IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(D0INIT)) C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(PERM) DO 40 I = 1, N IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 420 40 CONTINUE C C *** GET INITIAL FUNCTION VALUE *** C IV(1) = 1 GO TO 450 C 50 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 250 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 440 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 440 C C *** UPDATE THE SCALE VECTOR D *** C 70 DG1 = IV(DG) IF (IV(DTYPE) .LE. 0) GO TO 90 K = DG1 J = 0 DO 80 I = 1, N J = J + I V(K) = H(J) K = K + 1 80 CONTINUE CALL DD7DUP(D, V(DG1), IV, LIV, LV, N, V) C C *** COMPUTE SCALED GRADIENT AND ITS NORM *** C 90 DG1 = IV(DG) CALL DV7VMP(N, V(DG1), G, D, -1) C C *** COMPUTE SCALED HESSIAN *** C K = 1 DO 110 I = 1, N T = ONE / D(I) DO 100 J = 1, I H(K) = T * H(K) / D(J) K = K + 1 100 CONTINUE 110 CONTINUE C C *** CHOOSE INITIAL PERMUTATION *** C IPI = IV(PERM) IPN = IPI + N IPIV2 = IPN - 1 C *** INVERT OLD PERMUTATION ARRAY *** CALL I7PNVR(N, IV(IPN), IV(IPI)) K = IV(NC) DO 130 I = 1, N IF (B(1,I) .GE. B(2,I)) GO TO 120 XI = X(I) GI = G(I) IF (XI .LE. B(1,I) .AND. GI .GT. ZERO) GO TO 120 IF (XI .GE. B(2,I) .AND. GI .LT. ZERO) GO TO 120 IV(IPI) = I IPI = IPI + 1 J = IPIV2 + I C *** DISALLOW CONVERGENCE IF X(I) HAS JUST BEEN FREED *** IF (IV(J) .GT. K) IV(CNVCOD) = 0 GO TO 130 120 IPN = IPN - 1 IV(IPN) = I 130 CONTINUE IV(NC) = IPN - IV(PERM) C C *** PERMUTE SCALED GRADIENT AND HESSIAN ACCORDINGLY *** C IPI = IV(PERM) CALL DS7IPR(N, IV(IPI), H) CALL DV7IPR(N, IV(IPI), V(DG1)) V(DGNORM) = ZERO IF (IV(NC) .GT. 0) V(DGNORM) = DV2NRM(IV(NC), V(DG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 430 IF (IV(MODE) .EQ. 0) GO TO 380 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 140 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) 150 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 160 IV(1) = 10 GO TO 440 C 160 IV(NITER) = K + 1 C C *** INITIALIZE FOR START OF NEXT ITERATION *** C X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0 *** C CALL DV7CPY(N, V(X01), X) C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 180 STEP1 = IV(STEP) K = STEP1 DO 170 I = 1, N V(K) = D(I) * V(K) K = K + 1 170 CONTINUE T = V(RADFAC) * DV2NRM(N, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 180 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 210 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 190 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 160 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220 IV(1) = 9 210 IF (V(F) .GE. V(F0)) GO TO 440 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 370 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 220 STEP1 = IV(STEP) L = IV(LMAT) W1 = IV(W) IPI = IV(PERM) IPN = IPI + N IPIV2 = IPN + N TG1 = IV(DG) TD1 = TG1 + N X01 = IV(X0) X11 = X01 + N CALL DG7QSB(B, D, H, G, IV(IPI), IV(IPN), IV(IPIV2), IV(KAGQT), 1 V(L), LV, N, IV(N0), IV(NC), V(STEP1), V(TD1), V(TG1), 2 V, V(W1), V(X11), V(X01)) IF (IV(IRC) .NE. 6) GO TO 230 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 2 GO TO 260 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 230 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 250 IF (IV(IRC) .NE. 5) GO TO 240 IF (V(RADFAC) .LE. ONE) GO TO 240 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 0 GO TO 260 C C *** COMPUTE F(X0 + STEP) *** C 240 CALL DV2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 450 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 250 RSTRST = 3 260 X01 = IV(X0) V(RELDX) = DRLDST(N, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = STEP1 + 2*N I = IV(RESTOR) + 1 GO TO (300, 270, 280, 290), I 270 CALL DV7CPY(N, X, V(X01)) GO TO 300 280 CALL DV7CPY(N, V(LSTGST), X) GO TO 300 290 CALL DV7CPY(N, X, V(LSTGST)) CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X) V(RELDX) = DRLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 300 K = IV(IRC) GO TO (310,340,340,340,310,320,330,330,330,330,330,330,410,380), K C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 310 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 180 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 320 V(RADIUS) = V(LMAXS) GO TO 220 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 330 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 430 IF (IV(XIRC) .EQ. 14) GO TO 430 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 340 IF (IV(IRC) .NE. 3) GO TO 370 TEMP1 = LSTGST C C *** PREPARE FOR GRADIENT TESTS *** C *** SET TEMP1 = HESSIAN * STEP + G(X0) C *** = DIAG(D) * (H * STEP + G(X0)) C K = TEMP1 STEP0 = STEP1 - 1 IPI = IV(PERM) DO 350 I = 1, N J = IV(IPI) IPI = IPI + 1 STEP1 = STEP0 + J V(K) = D(J) * V(STEP1) K = K + 1 350 CONTINUE C USE X0 VECTOR AS TEMPORARY. CALL DS7LVM(N, V(X01), H, V(TEMP1)) TEMP0 = TEMP1 - 1 IPI = IV(PERM) DO 360 I = 1, N J = IV(IPI) IPI = IPI + 1 TEMP1 = TEMP0 + J V(TEMP1) = D(J) * V(X01) + G(J) X01 = X01 + 1 360 CONTINUE C C *** COMPUTE GRADIENT AND HESSIAN *** C 370 IV(NGCALL) = IV(NGCALL) + 1 IV(TOOBIG) = 0 IV(1) = 2 GO TO 450 C 380 IV(1) = 2 IF (IV(IRC) .NE. 3) GO TO 140 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C STEP1 = IV(STEP) C *** TEMP1 = STLSTG *** TEMP1 = STEP1 + 2*N C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C K = TEMP1 DO 390 I = 1, N V(K) = (V(K) - G(I)) / D(I) K = K + 1 390 CONTINUE C C *** DO GRADIENT TESTS *** C IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 400 IF (DD7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 140 400 V(RADFAC) = V(INCFAC) GO TO 140 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 410 IV(1) = 64 GO TO 440 C C *** INCONSISTENT B *** C 420 IV(1) = 82 GO TO 440 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 430 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 440 CALL DITSUM(D, G, IV, LIV, LV, N, V, X) GO TO 999 C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 450 DO 460 I = 1, N IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 460 CONTINUE C 999 RETURN C C *** LAST CARD OF DRMNHB FOLLOWS *** END SUBROUTINE DRN2G(D, DR, IV, LIV, LV, N, ND, N1, N2, P, R, 1 RD, V, X) C C *** REVISED ITERATION DRIVER FOR NL2SOL (VERSION 2.3) *** C INTEGER LIV, LV, N, ND, N1, N2, P INTEGER IV(LIV) DOUBLE PRECISION D(P), DR(ND,P), R(ND), RD(ND), V(LV), X(P) C C-------------------------- PARAMETER USAGE -------------------------- C C D........ SCALE VECTOR. C DR....... DERIVATIVES OF R AT X. C IV....... INTEGER VALUES ARRAY. C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST P + 82. C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+16). C N........ TOTAL NUMBER OF RESIDUALS. C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL. C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C R........ RESIDUALS. C RD....... RD(I) = SQRT(G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN C IV(RDREQ) IS NONZERO. DRN2G SETS IV(REGD) = 1 IF RD C IS SUCCESSFULLY COMPUTED, TO 0 IF NO ATTEMPT WAS MADE C TO COMPUTE IT, AND TO -1 IF H (THE FINITE-DIFFERENCE HESSIAN) C WAS INDEFINITE. IF ND .GE. N, THEN RD IS ALSO USED AS C TEMPORARY STORAGE. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** DISCUSSION *** C C NOTE... NL2SOL AND NL2ITR (MENTIONED BELOW) ARE DESCRIBED IN C ACM TRANS. MATH. SOFTWARE, VOL. 7, PP. 369-383 (AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, D.M. GAY, C AND R.E. WELSCH). C C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR C LEAST SQUARES PROBLEMS. WHEN ND = N, IT IS SIMILAR TO NL2ITR C (WITH J = DR), EXCEPT THAT R(X) AND DR(X) NEED NOT BE INITIALIZED C WHEN DRN2G IS CALLED WITH IV(1) = 0 OR 12. DRN2G ALSO ALLOWS C R AND DR TO BE SUPPLIED ROW-WISE -- JUST SET ND = 1 AND CALL C DRN2G ONCE FOR EACH ROW WHEN PROVIDING RESIDUALS AND JACOBIANS. C ANOTHER NEW FEATURE IS THAT CALLING DRN2G WITH IV(1) = 13 C CAUSES STORAGE ALLOCATION ONLY TO BE PERFORMED -- ON RETURN, SUCH C COMPONENTS AS IV(G) (THE FIRST SUBSCRIPT IN G OF THE GRADIENT) C AND IV(S) (THE FIRST SUBSCRIPT IN V OF THE S LOWER TRIANGLE OF C THE S MATRIX) WILL HAVE BEEN SET (UNLESS LIV OR LV IS TOO SMALL), C AND IV(1) WILL HAVE BEEN SET TO 14. CALLING DRN2G WITH IV(1) = 14 C CAUSES EXECUTION OF THE ALGORITHM TO BEGIN UNDER THE ASSUMPTION C THAT STORAGE HAS BEEN ALLOCATED. C C *** SUPPLYING R AND DR *** C C DRN2G USES IV AND V IN THE SAME WAY AS NL2SOL, WITH A SMALL C NUMBER OF OBVIOUS CHANGES. ONE DIFFERENCE BETWEEN DRN2G AND C NL2ITR IS THAT INITIAL FUNCTION AND GRADIENT INFORMATION NEED NOT C BE SUPPLIED IN THE VERY FIRST CALL ON DRN2G, THE ONE WITH C IV(1) = 0 OR 12. ANOTHER DIFFERENCE IS THAT DRN2G RETURNS WITH C IV(1) = -2 WHEN IT WANTS ANOTHER LOOK AT THE OLD JACOBIAN MATRIX C AND THE CURRENT RESIDUAL -- THE ONE CORRESPONDING TO X AND C IV(NFGCAL). IT THEN RETURNS WITH IV(1) = -3 WHEN IT WANTS TO SEE C BOTH THE NEW RESIDUAL AND THE NEW JACOBIAN MATRIX AT ONCE. NOTE C THAT IV(NFGCAL) = IV(7) CONTAINS THE VALUE THAT IV(NFCALL) = IV(6) C HAD WHEN THE CURRENT RESIDUAL WAS EVALUATED. ALSO NOTE THAT THE C VALUE OF X CORRESPONDING TO THE OLD JACOBIAN MATRIX IS STORED IN C V, STARTING AT V(IV(X0)) = V(IV(43)). C ANOTHER NEW RETURN... DRN2G IV(1) = -1 WHEN IT WANTS BOTH THE C RESIDUAL AND THE JACOBIAN TO BE EVALUATED AT X. C A NEW RESIDUAL VECTOR MUST BE SUPPLIED WHEN DRN2G RETURNS WITH C IV(1) = 1 OR -1. THIS TAKES THE FORM OF VALUES OF R(I,X) PASSED C IN R(I-N1+1), I = N1(1)N2. YOU MAY PASS ALL THESE VALUES AT ONCE C (I.E., N1 = 1 AND N2 = N) OR IN PIECES BY MAKING SEVERAL CALLS ON C DRN2G. EACH TIME DRN2G RETURNS WITH IV(1) = 1, N1 WILL HAVE C BEEN SET TO THE INDEX OF THE NEXT RESIDUAL THAT DRN2G EXPECTS TO C SEE, AND N2 WILL BE SET TO THE INDEX OF THE HIGHEST RESIDUAL THAT C COULD BE GIVEN ON THE NEXT CALL, I.E., N2 = N1 + ND - 1. (THUS C WHEN DRN2G FIRST RETURNS WITH IV(1) = 1 FOR A NEW X, IT WILL C HAVE SET N1 TO 1 AND N2 TO MIN(ND,N).) THE CALLER MAY PROVIDE C FEWER THAN N2-N1+1 RESIDUALS ON THE NEXT CALL BY SETTING N2 TO C A SMALLER VALUE. DRN2G ASSUMES IT HAS SEEN ALL THE RESIDUALS C FOR THE CURRENT X WHEN IT IS CALLED WITH N2 .GE. N. C EXAMPLE... SUPPOSE N = 80 AND THAT R IS TO BE PASSED IN 8 C BLOCKS OF SIZE 10. THE FOLLOWING CODE WOULD DO THE JOB. C C N = 80 C ND = 10 C ... C DO 10 K = 1, 8 C *** COMPUTE R(I,X) FOR I = 10*K-9 TO 10*K *** C *** AND STORE THEM IN R(1),...,R(10) *** C CALL DRN2G(..., R, ...) C 10 CONTINUE C C THE SITUATION IS SIMILAR WHEN GRADIENT INFORMATION IS C REQUIRED, I.E., WHEN DRN2G RETURNS WITH IV(1) = 2, -1, OR -2. C NOTE THAT DRN2G OVERWRITES R, BUT THAT IN THE SPECIAL CASE OF C N1 = 1 AND N2 = N ON PREVIOUS CALLS, DRN2G NEVER RETURNS WITH C IV(1) = -2. IT SHOULD BE CLEAR THAT THE PARTIAL DERIVATIVE OF C R(I,X) WITH RESPECT TO X(L) IS TO BE STORED IN DR(I-N1+1,L), C L = 1(1)P, I = N1(1)N2. IT IS ESSENTIAL THAT R(I) AND DR(I,L) C ALL CORRESPOND TO THE SAME RESIDUALS WHEN IV(1) = -1 OR -2. C C *** COVARIANCE MATRIX *** C C IV(RDREQ) = IV(57) TELLS WHETHER TO COMPUTE A COVARIANCE C MATRIX AND/OR REGRESSION DIAGNOSTICS... 0 MEANS NEITHER, C 1 MEANS COVARIANCE MATRIX ONLY, 2 MEANS REG. DIAGNOSTICS ONLY, C 3 MEANS BOTH. AS WITH NL2SOL, IV(COVREQ) = IV(15) TELLS WHAT C HESSIAN APPROXIMATION TO USE IN THIS COMPUTING. C C *** REGRESSION DIAGNOSTICS *** C C SEE THE COMMENTS IN SUBROUTINE DN2G. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS, MOD C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DC7VFN,DIVSET, DD7TPR,DD7UPD,DG7LIT,DITSUM,DL7VML, 1 DN2CVP, DN2LRD, DQ7APL,DQ7RAD,DV7CPY, DV7SCP, DV2NRM C C DC7VFN... FINISHES COVARIANCE COMPUTATION. C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C DD7UPD... UPDATES SCALE VECTOR D. C DG7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM. C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DN2CVP... PRINTS COVARIANCE MATRIX. C DN2LRD... COMPUTES REGRESSION DIAGNOSTICS. C DQ7APL... APPLIES QR TRANSFORMATIONS STORED BY DQ7RAD. C DQ7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C INTEGER G1, GI, I, IV1, IVMODE, JTOL1, K, L, LH, NN, QTR1, 1 RMAT1, YI, Y1 DOUBLE PRECISION T C DOUBLE PRECISION HALF, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COVMAT, COVREQ, DINIT, DTYPE, DTINIT, D0INIT, F, 1 FDH, G, H, IPIVOT, IVNEED, JCN, JTOL, LMAT, MODE, 2 NEXTIV, NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, 3 NGCALL, NGCOV, QTR, RDREQ, REGD, RESTOR, RLIMIT, RMAT, 4 TOOBIG, VNEED, Y C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DTYPE/16/, FDH/74/, C 1 G/28/, H/56/, IPIVOT/76/, IVNEED/3/, JCN/66/, JTOL/59/, C 2 LMAT/42/, MODE/35/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, C 3 NFCOV/52/, NF0/68/, NF00/81/, NF1/69/, NFGCAL/7/, NGCALL/30/, C 4 NGCOV/53/, QTR/77/, RESTOR/9/, RMAT/78/, RDREQ/57/, REGD/67/, C 5 TOOBIG/2/, VNEED/4/, Y/48/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DTYPE=16, FDH=74, 1 G=28, H=56, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59, 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6, 3 NFCOV=52, NF0=68, NF00=81, NF1=69, NFGCAL=7, NGCALL=30, 4 NGCOV=53, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, REGD=67, 5 TOOBIG=2, VNEED=4, Y=48) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/ C/7 PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) C/ C/6 C DATA HALF/0.5D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 NN = N2 - N1 + 1 IV(RESTOR) = 0 I = IV1 + 4 IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I IF (I .NE. 5) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LE. 0) GO TO 210 IF (P .LE. 0) GO TO 210 IF (N .LE. 0) GO TO 210 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 300 IF (IV1 .LT. 12) GO TO 40 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 20 IV(IVNEED) = IV(IVNEED) + P IV(VNEED) = IV(VNEED) + P*(P+13)/2 20 CALL DG7LIT(D, X, IV, LIV, LV, P, P, V, X, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IPIVOT) = IV(NEXTIV) IV(NEXTIV) = IV(IPIVOT) + P IV(Y) = IV(NEXTV) IV(G) = IV(Y) + P IV(JCN) = IV(G) + P IV(RMAT) = IV(JCN) + P IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + P IV(NEXTV) = IV(JTOL) + 2*P IF (IV1 .EQ. 13) GO TO 999 C 30 JTOL1 = IV(JTOL) IF (V(DINIT) .GE. ZERO) CALL DV7SCP(P, D, V(DINIT)) IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(P, V(JTOL1), V(DTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(P, V(I), V(D0INIT)) IV(NF0) = 0 IV(NF1) = 0 IF (ND .GE. N) GO TO 40 C C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE C G1 = IV(G) Y1 = IV(Y) CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 1) GO TO 220 V(F) = ZERO CALL DV7SCP(P, V(G1), ZERO) IV(1) = -1 QTR1 = IV(QTR) CALL DV7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 RMAT1 = IV(RMAT) GO TO 100 C 40 G1 = IV(G) Y1 = IV(Y) CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 220 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 260 IF (IV(RESTOR) .NE. 2) GO TO 260 IV(NF0) = IV(NF1) CALL DV7CPY(N, RD, R) IV(REGD) = 0 GO TO 260 C 60 CALL DV7SCP(P, V(G1), ZERO) IF (IV(MODE) .GT. 0) GO TO 230 RMAT1 = IV(RMAT) QTR1 = IV(QTR) CALL DV7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 IF (ND .LT. N) GO TO 90 IF (N1 .NE. 1) GO TO 90 IF (IV(MODE) .LT. 0) GO TO 100 IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70 IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90 CALL DV7CPY(N, R, RD) GO TO 80 70 CALL DV7CPY(N, RD, R) 80 CALL DQ7APL(ND, N, P, DR, RD, 0) CALL DL7VML(P, V(Y1), V(RMAT1), RD) GO TO 110 C 90 IV(1) = -2 IF (IV(MODE) .LT. 0) IV(1) = -1 100 CALL DV7SCP(P, V(Y1), ZERO) 110 CALL DV7SCP(LH, V(RMAT1), ZERO) GO TO 260 C C *** COMPUTE F(X) *** C 120 T = DV2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 200 V(F) = V(F) + HALF * T**2 IF (N2 .LT. N) GO TO 270 IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL) GO TO 40 C C *** COMPUTE Y *** C 130 Y1 = IV(Y) YI = Y1 DO 140 L = 1, P V(YI) = V(YI) + DD7TPR(NN, DR(1,L), R) YI = YI + 1 140 CONTINUE IF (N2 .LT. N) GO TO 270 IV(1) = 2 IF (N1 .GT. 1) IV(1) = -3 GO TO 260 C C *** COMPUTE GRADIENT INFORMATION *** C 150 IF (IV(MODE) .GT. P) GO TO 240 G1 = IV(G) IVMODE = IV(MODE) IF (IVMODE .LT. 0) GO TO 170 IF (IVMODE .EQ. 0) GO TO 180 IV(1) = 2 C C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) *** C GI = G1 DO 160 L = 1, P V(GI) = V(GI) + DD7TPR(NN, R, DR(1,L)) GI = GI + 1 160 CONTINUE GO TO 190 C C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N *** C 170 IF (N .LE. ND) GO TO 180 T = DV2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 200 V(F) = V(F) + HALF * T**2 C C *** UPDATE D IF DESIRED *** C 180 IF (IV(DTYPE) .GT. 0) 1 CALL DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** COMPUTE RMAT AND QTR *** C QTR1 = IV(QTR) RMAT1 = IV(RMAT) CALL DQ7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R) IV(NF1) = 0 C 190 IF (N2 .LT. N) GO TO 270 IF (IVMODE .GT. 0) GO TO 40 IV(NF00) = IV(NFGCAL) C C *** COMPUTE G FROM RMAT AND QTR *** C CALL DL7VML(P, V(G1), V(RMAT1), V(QTR1)) IV(1) = 2 IF (IVMODE .EQ. 0) GO TO 40 IF (N .LE. ND) GO TO 40 C C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT C Y1 = IV(Y) IV(1) = 1 CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 2) GO TO 220 GO TO 40 C C *** MISC. DETAILS *** C C *** X IS OUT OF RANGE (OVERSIZE STEP) *** C 200 IV(TOOBIG) = 1 GO TO 40 C C *** BAD N, ND, OR P *** C 210 IV(1) = 66 GO TO 300 C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 220 IF (IV(COVMAT) .NE. 0) GO TO 290 IF (IV(REGD) .NE. 0) GO TO 290 C C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE *** C K = IV(FDH) IF (K .LE. 0) GO TO 280 IF (IV(RDREQ) .LE. 0) GO TO 290 C C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF C DESIRED *** C I = 0 IF (MOD(IV(RDREQ),4) .GE. 2) I = 1 IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .LE. 1) I = I+2 IF (I .EQ. 0) GO TO 250 IV(MODE) = P + I IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 IV(CNVCOD) = IV(1) IF (I .LT. 2) GO TO 230 L = IABS(IV(H)) CALL DV7SCP(LH, V(L), ZERO) 230 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 GO TO 260 C 240 L = IV(LMAT) CALL DN2LRD(DR, IV, V(L), LH, LIV, LV, ND, NN, P, R, RD, V) IF (N2 .LT. N) GO TO 270 IF (N1 .GT. 1) GO TO 250 C C *** ENSURE WE CAN RESTART -- AND MAKE RETURN STATE OF DR C *** INDEPENDENT OF WHETHER REGRESSION DIAGNOSTICS ARE COMPUTED. C *** USE STEP VECTOR (ALLOCATED BY DG7LIT) FOR SCRATCH. C RMAT1 = IV(RMAT) CALL DV7SCP(LH, V(RMAT1), ZERO) CALL DQ7RAD(NN, ND, P, R, .FALSE., V(RMAT1), DR, R) IV(NF1) = 0 C C *** FINISH COMPUTING COVARIANCE *** C 250 L = IV(LMAT) CALL DC7VFN(IV, V(L), LH, LIV, LV, N, P, V) GO TO 290 C C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION *** C 260 N2 = 0 270 N1 = N2 + 1 N2 = N2 + ND IF (N2 .GT. N) N2 = N GO TO 999 C C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN *** C 280 IV(COVMAT) = K IV(REGD) = K C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 290 G1 = IV(G) 300 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X) IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0) 1 CALL DN2CVP(IV, LIV, LV, P, V) C 999 RETURN C *** LAST LINE OF DRN2G FOLLOWS *** END SUBROUTINE DRN2GB(B, D, DR, IV, LIV, LV, N, ND, N1, N2, P, R, 1 RD, V, X) C C *** REVISED ITERATION DRIVER FOR NL2SOL WITH SIMPLE BOUNDS *** C INTEGER LIV, LV, N, ND, N1, N2, P INTEGER IV(LIV) DOUBLE PRECISION B(2,P), D(P), DR(ND,P), R(ND), RD(ND), V(LV), 1 X(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B........ BOUNDS ON X. C D........ SCALE VECTOR. C DR....... DERIVATIVES OF R AT X. C IV....... INTEGER VALUES ARRAY. C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82. C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20). C N........ TOTAL NUMBER OF RESIDUALS. C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL. C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C R........ RESIDUALS. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** DISCUSSION *** C C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR C LEAST SQUARES PROBLEMS. IT IS SIMILAR TO DRN2G, EXCEPT THAT C THIS ROUTINE ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DIVSET, DD7TPR,DD7UPD, DG7ITB,DITSUM,DL7VML, DQ7APL, 1 DQ7RAD, DR7TVM,DV7CPY, DV7SCP, DV2NRM C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C DD7UPD... UPDATES SCALE VECTOR D. C DG7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM. C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DQ7APL... APPLIES QR TRANSFORMATIONS STORED BY DQ7RAD. C DQ7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION. C DR7TVM... MULT. VECTOR BY TRANS. OF UPPER TRIANG. MATRIX FROM QR FACT. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C C C *** LOCAL VARIABLES *** C INTEGER G1, GI, I, IV1, IVMODE, JTOL1, L, LH, NN, QTR1, 1 RD1, RMAT1, YI, Y1 DOUBLE PRECISION T C DOUBLE PRECISION HALF, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, G, JCN, JTOL, MODE, 1 NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, QTR, RDREQ, 1 REGD, RESTOR, RLIMIT, RMAT, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA DTYPE/16/, G/28/, JCN/66/, JTOL/59/, MODE/35/, NEXTV/47/, C 1 NF0/68/, NF00/81/, NF1/69/, NFCALL/6/, NFCOV/52/, NFGCAL/7/, C 2 QTR/77/, RDREQ/57/, RESTOR/9/, REGD/67/, RMAT/78/, TOOBIG/2/, C 3 VNEED/4/ C/7 PARAMETER (DTYPE=16, G=28, JCN=66, JTOL=59, MODE=35, NEXTV=47, 1 NF0=68, NF00=81, NF1=69, NFCALL=6, NFCOV=52, NFGCAL=7, 2 QTR=77, RDREQ=57, RESTOR=9, REGD=67, RMAT=78, TOOBIG=2, 3 VNEED=4) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/ C/7 PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) C/ C/6 C DATA HALF/0.5D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 NN = N2 - N1 + 1 IV(RESTOR) = 0 I = IV1 + 4 IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I IF (I .NE. 5) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LE. 0) GO TO 220 IF (P .LE. 0) GO TO 220 IF (N .LE. 0) GO TO 220 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 270 IF (IV1 .LT. 12) GO TO 40 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 20 IV(VNEED) = IV(VNEED) + P*(P+15)/2 20 CALL DG7ITB(B, D, X, IV, LIV, LV, P, P, V, X, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) IV(JCN) = IV(G) + 2*P IV(RMAT) = IV(JCN) + P IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + 2*P IV(NEXTV) = IV(JTOL) + 2*P C *** TURN OFF COVARIANCE COMPUTATION *** IV(RDREQ) = 0 IF (IV1 .EQ. 13) GO TO 999 C 30 JTOL1 = IV(JTOL) IF (V(DINIT) .GE. ZERO) CALL DV7SCP(P, D, V(DINIT)) IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(P, V(JTOL1), V(DTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(P, V(I), V(D0INIT)) IV(NF0) = 0 IV(NF1) = 0 IF (ND .GE. N) GO TO 40 C C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE C G1 = IV(G) Y1 = G1 + P CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 1) GO TO 260 V(F) = ZERO CALL DV7SCP(P, V(G1), ZERO) IV(1) = -1 QTR1 = IV(QTR) CALL DV7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 RMAT1 = IV(RMAT) GO TO 100 C 40 G1 = IV(G) Y1 = G1 + P CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 260 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 240 IV(NF0) = IV(NF1) CALL DV7CPY(N, RD, R) IV(REGD) = 0 GO TO 240 C 60 CALL DV7SCP(P, V(G1), ZERO) IF (IV(MODE) .GT. 0) GO TO 230 RMAT1 = IV(RMAT) QTR1 = IV(QTR) RD1 = QTR1 + P CALL DV7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 IF (ND .LT. N) GO TO 90 IF (N1 .NE. 1) GO TO 90 IF (IV(MODE) .LT. 0) GO TO 100 IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70 IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90 CALL DV7CPY(N, R, RD) GO TO 80 70 CALL DV7CPY(N, RD, R) 80 CALL DQ7APL(ND, N, P, DR, RD, 0) CALL DR7TVM(ND, MIN0(N,P), V(Y1), V(RD1), DR, RD) IV(REGD) = 0 GO TO 110 C 90 IV(1) = -2 IF (IV(MODE) .LT. 0) IV(1) = -3 100 CALL DV7SCP(P, V(Y1), ZERO) 110 CALL DV7SCP(LH, V(RMAT1), ZERO) GO TO 240 C C *** COMPUTE F(X) *** C 120 T = DV2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 210 V(F) = V(F) + HALF * T**2 IF (N2 .LT. N) GO TO 250 IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL) GO TO 40 C C *** COMPUTE Y *** C 130 Y1 = IV(G) + P YI = Y1 DO 140 L = 1, P V(YI) = V(YI) + DD7TPR(NN, DR(1,L), R) YI = YI + 1 140 CONTINUE IF (N2 .LT. N) GO TO 250 IV(1) = 2 IF (N1 .GT. 1) IV(1) = -3 GO TO 240 C C *** COMPUTE GRADIENT INFORMATION *** C 150 G1 = IV(G) IVMODE = IV(MODE) IF (IVMODE .LT. 0) GO TO 170 IF (IVMODE .EQ. 0) GO TO 180 IV(1) = 2 C C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) *** C GI = G1 DO 160 L = 1, P V(GI) = V(GI) + DD7TPR(NN, R, DR(1,L)) GI = GI + 1 160 CONTINUE GO TO 200 C C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N *** C 170 IF (N .LE. ND) GO TO 180 T = DV2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 210 V(F) = V(F) + HALF * T**2 C C *** UPDATE D IF DESIRED *** C 180 IF (IV(DTYPE) .GT. 0) 1 CALL DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** COMPUTE RMAT AND QTR *** C QTR1 = IV(QTR) RMAT1 = IV(RMAT) CALL DQ7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R) IV(NF1) = 0 IF (N1 .GT. 1) GO TO 200 IF (N2 .LT. N) GO TO 250 C C *** SAVE DIAGONAL OF R FOR COMPUTING Y LATER *** C RD1 = QTR1 + P L = RMAT1 - 1 DO 190 I = 1, P L = L + I V(RD1) = V(L) RD1 = RD1 + 1 190 CONTINUE C 200 IF (N2 .LT. N) GO TO 250 IF (IVMODE .GT. 0) GO TO 40 IV(NF00) = IV(NFGCAL) C C *** COMPUTE G FROM RMAT AND QTR *** C CALL DL7VML(P, V(G1), V(RMAT1), V(QTR1)) IV(1) = 2 IF (IVMODE .EQ. 0) GO TO 40 IF (N .LE. ND) GO TO 40 C C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT C Y1 = G1 + P IV(1) = 1 CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 2) GO TO 260 GO TO 40 C C *** MISC. DETAILS *** C C *** X IS OUT OF RANGE (OVERSIZE STEP) *** C 210 IV(TOOBIG) = 1 GO TO 40 C C *** BAD N, ND, OR P *** C 220 IV(1) = 66 GO TO 270 C C *** RECORD EXTRA EVALUATIONS FOR FINITE-DIFFERENCE HESSIAN *** C 230 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 C C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION *** C 240 N2 = 0 250 N1 = N2 + 1 N2 = N2 + ND IF (N2 .GT. N) N2 = N GO TO 999 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 260 G1 = IV(G) 270 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X) C 999 RETURN C *** LAST CARD OF DRN2GB FOLLOWS *** END SUBROUTINE DRNSG(A, ALF, C, DA, IN, IV, L, L1, LA, LIV, LV, 1 N, NDA, P, V, Y) C C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES. C C *** PARAMETER DECLARATIONS *** C INTEGER L, L1, LA, LIV, LV, N, NDA, P INTEGER IN(2,NDA), IV(LIV) C DIMENSION UIPARM(*) DOUBLE PRECISION A(LA,L1), ALF(P), C(L), DA(LA,NDA), V(LV), Y(N) C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), DRNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )). C I=1 I I C C THE (L+1)ST TERM IS OPTIONAL. C C C *** PARAMETERS *** C C A (IN) MATRIX PHI(ALF,T) OF THE MODEL. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C C (OUT) LINEAR PARAMETERS (ESTIMATED). C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS C OF ALF, AS SPECIFIED BY THE IN ARRAY... C IN (IN) WHEN DRNSG IS CALLED WITH IV(1) = 2 OR -2, THEN FOR C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2 C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND C DRNSG SHOULD RETURN FOR THEM. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. DRNSG RETURNS C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2 C (AFTER A RETURN WITH IV(1) = 2), DRNSG RETURNS C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT. C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + P. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + 2*N + JLEN + L*(L+3)/2 + P*(2*P + 17), C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE C REQUESTED, IN WHICH CASE JLEN = N*P. C N (IN) NUMBER OF OBSERVATIONS. C NDA (IN) NUMBER OF COLUMNS IN DA AND IN. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST, C FOLLOWED BY LINEAR PARAMETERS. C Y (IN) RIGHT-HAND SIDE VECTOR. C C C *** EXTERNAL SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DR7MDC EXTERNAL DC7VFN,DIVSET, DD7TPR,DITSUM, DL7ITV,DL7SRT, DL7SVX, 1 DL7SVN, DN2CVP, DN2LRD, DN2RDP, DRN2G, DQ7APL,DQ7RAD, 2 DQ7RFH, DR7MDC, DS7CPR,DV2AXY,DV7CPY,DV7PRM, DV7SCL, 3 DV7SCP C C DC7VFN... FINISHES COVARIANCE COMPUTATION. C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF. C DL7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SRT.... COMPUTES (PARTIAL) CHOLESKY FACTORIZATION. C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C DN2CVP... PRINTS COVARIANCE MATRIX. C DN2LRD... COMPUTES COVARIANCE AND REGRESSION DIAGNOSTICS. C DN2RDP... PRINTS REGRESSION DIAGNOSTICS. C DRN2G... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER. C DQ7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY DQ7RFH. C DQ7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING. C DQ7RAD.... QR FACT., NO PIVOTING. C DR7MDC... RETURNS MACHINE-DEP. CONSTANTS. C DS7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION. C DV2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7PRM.... PERMUTES A VECTOR. C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C LOGICAL NOCOV INTEGER AR1, CSAVE1, D1, DR1, DR1L, DRI, DRI1, FDH0, HSAVE, I, I1, 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1, N2, 2 NML, NRAN, PP, PP1, R1, R1L, RD1, TEMP1 DOUBLE PRECISION SINGTL, T DOUBLE PRECISION MACHEP, NEGONE, SNGFAC, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AR, CNVCOD, COVMAT, COVREQ, CSAVE, CVRQSV, D, FDH, H, 1 IERS, IPIVS, IV1SAV, IVNEED, J, LMAT, MODE, NEXTIV, NEXTV, 2 NFCALL, NFCOV, NFGCAL, NGCALL, NGCOV, PERM, R, RCOND, 3 RDREQ, RDRQSV, REGD, REGD0, RESTOR, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AR/110/, CNVCOD/55/, COVMAT/26/, COVREQ/15/, CSAVE/105/, C 1 CVRQSV/106/, D/27/, FDH/74/, H/56/, IERS/108/, IPIVS/109/, C 2 IV1SAV/104/, IVNEED/3/, J/70/, LMAT/42/, MODE/35/, C 3 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFCOV/52/, NFGCAL/7/, C 4 NGCALL/30/, NGCOV/53/, PERM/58/, R/61/, RCOND/53/, RDREQ/57/, C 5 RDRQSV/107/, REGD/67/, REGD0/82/, RESTOR/9/, TOOBIG/2/, C 6 VNEED/4/ C/7 PARAMETER (AR=110, CNVCOD=55, COVMAT=26, COVREQ=15, CSAVE=105, 1 CVRQSV=106, D=27, FDH=74, H=56, IERS=108, IPIVS=109, 2 IV1SAV=104, IVNEED=3, J=70, LMAT=42, MODE=35, 3 NEXTIV=46, NEXTV=47, NFCALL=6, NFCOV=52, NFGCAL=7, 4 NGCALL=30, NGCOV=53, PERM=58, R=61, RCOND=53, RDREQ=57, 5 RDRQSV=107, REGD=67, REGD0=82, RESTOR=9, TOOBIG=2, 6 VNEED=4) C/ DATA MACHEP/-1.D+0/, NEGONE/-1.D+0/, SNGFAC/1.D+2/, ZERO/0.D+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) N1 = 1 NML = N IV1 = IV(1) IF (IV1 .LE. 2) GO TO 20 C C *** CHECK INPUT INTEGERS *** C IF (P .LE. 0) GO TO 370 IF (L .LT. 0) GO TO 370 IF (N .LE. L) GO TO 370 IF (LA .LT. N) GO TO 370 IF (IV1 .LT. 12) GO TO 20 IF (IV1 .EQ. 14) GO TO 20 IF (IV1 .EQ. 12) IV(1) = 13 C C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS *** C IF (IV(1) .GT. 16) GO TO 370 LL1O2 = L*(L+1)/2 JLEN = N*P I = L + P IF (IV(RDREQ) .GT. 0 .AND. IV(COVREQ) .NE. 0) JLEN = I*(N + I + 1) IF (IV(1) .NE. 13) GO TO 10 IV(IVNEED) = IV(IVNEED) + L IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1 CALL DRN2G(V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IPIVS) = IV(NEXTIV) IV(NEXTIV) = IV(NEXTIV) + L IV(D) = IV(NEXTV) IV(REGD0) = IV(D) + P IV(AR) = IV(REGD0) + N IV(CSAVE) = IV(AR) + LL1O2 IV(J) = IV(CSAVE) + L IV(R) = IV(J) + JLEN IV(NEXTV) = IV(R) + N IV(IERS) = 0 IF (IV1 .EQ. 13) GO TO 999 C C *** SET POINTERS INTO IV AND V *** C 20 AR1 = IV(AR) D1 = IV(D) DR1 = IV(J) DR1L = DR1 + L R1 = IV(R) R1L = R1 + L RD1 = IV(REGD0) CSAVE1 = IV(CSAVE) NML = N - L IF (IV1 .LE. 2) GO TO 50 C C *** IF F.D. HESSIAN WILL BE NEEDED (FOR COVARIANCE OR REG. C *** DIAGNOSTICS), HAVE DRN2G COMPUTE ONLY THE PART CORRESP. C *** TO ALF WITH C FIXED... C IF (L .LE. 0) GO TO 30 IV(CVRQSV) = IV(COVREQ) IF (IABS(IV(COVREQ)) .GE. 3) IV(COVREQ) = 0 IV(RDRQSV) = IV(RDREQ) IF (IV(RDREQ) .GT. 0) IV(RDREQ) = -1 C 30 N2 = NML CALL DRN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P, 1 V(R1L), V(RD1), V, ALF) IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0) 1 CALL DV7CPY(L, C, V(CSAVE1)) IV1 = IV(1) IF (IV1-2) 40, 150, 230 C C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED *** C 40 IV(IV1SAV) = IV(1) IV(1) = IABS(IV1) IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL DV7CPY(L, V(CSAVE1), C) GO TO 999 C C *** COMPUTE NEW RESIDUAL OR GRADIENT *** C 50 IV(1) = IV(IV1SAV) MD = IV(MODE) IF (MD .LE. 0) GO TO 60 NML = N DR1L = DR1 R1L = R1 60 IF (IV(TOOBIG) .NE. 0) GO TO 30 IF (IABS(IV1) .EQ. 2) GO TO 170 C C *** COMPUTE NEW RESIDUAL *** C IF (L1 .LE. L) CALL DV7CPY(N, V(R1), Y) IF (L1 .GT. L) CALL DV2AXY(N, V(R1), NEGONE, A(1,L1), Y) IF (MD .GT. 0) GO TO 120 IER = 0 IF (L .LE. 0) GO TO 110 LL1O2 = L * (L + 1) / 2 IPIV1 = IV(IPIVS) CALL DQ7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C) C C *** DETERMINE NUMERICAL RANK OF A *** C IF (MACHEP .LE. ZERO) MACHEP = DR7MDC(3) SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP K = L IF (IER .NE. 0) K = IER - 1 70 IF (K .LE. 0) GO TO 90 T = DL7SVX(K, V(AR1), C, C) IF (T .GT. ZERO) T = DL7SVN(K, V(AR1), C, C) / T IF (T .GT. SINGTL) GO TO 80 K = K - 1 GO TO 70 C C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK, C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1. C 80 IF (K .GE. L) GO TO 100 90 IER = K + 1 CALL DV7SCP(L-K, C(K+1), ZERO) 100 IV(IERS) = IER IF (K .LE. 0) GO TO 110 C C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS... C CALL DQ7APL(LA, N, K, A, V(R1), IER) C C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT C *** THE LAST ITERATION. C CALL DL7ITV(K, C, V(AR1), V(R1)) CALL DV7PRM(L, IV(IPIV1), C) C 110 IF(IV(1) .LT. 2) GO TO 220 GO TO 999 C C C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN *** C 120 IF (L .LE. 0) GO TO 140 DO 130 I = 1, L 130 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1)) 140 IF (IV(1) .GT. 0) GO TO 30 IV(1) = 2 GO TO 160 C C *** NEW GRADIENT (JACOBIAN) NEEDED *** C 150 IV(IV1SAV) = IV1 IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1 160 CALL DV7SCP(N*P, V(DR1), ZERO) GO TO 999 C C *** COMPUTE NEW JACOBIAN *** C 170 NOCOV = MD .LE. P .OR. IABS(IV(COVREQ)) .GE. 3 FDH0 = DR1 + N*(P+L) IF (NDA .LE. 0) GO TO 370 DO 180 I = 1, NDA I1 = IN(1,I) - 1 IF (I1 .LT. 0) GO TO 180 J1 = IN(2,I) K = DR1 + I1*N T = NEGONE IF (J1 .LE. L) T = -C(J1) CALL DV2AXY(N, V(K), T, DA(1,I), V(K)) IF (NOCOV) GO TO 180 IF (J1 .GT. L) GO TO 180 C *** ADD IN (L,P) PORTION OF SECOND-ORDER PART OF HESSIAN C *** FOR COVARIANCE OR REG. DIAG. COMPUTATIONS... J1 = J1 + P K = FDH0 + J1*(J1-1)/2 + I1 V(K) = V(K) - DD7TPR(N, V(R1), DA(1,I)) 180 CONTINUE IF (IV1 .EQ. 2) GO TO 190 IV(1) = IV1 GO TO 999 190 IF (L .LE. 0) GO TO 30 IF (MD .GT. P) GO TO 240 IF (MD .GT. 0) GO TO 30 K = DR1 IER = IV(IERS) NRAN = L IF (IER .GT. 0) NRAN = IER - 1 IF (NRAN .LE. 0) GO TO 210 DO 200 I = 1, P CALL DQ7APL(LA, N, NRAN, A, V(K), IER) K = K + N 200 CONTINUE 210 CALL DV7CPY(L, V(CSAVE1), C) 220 IF (IER .EQ. 0) GO TO 30 C C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR... C NRAN = IER - 1 DR1L = DR1 + NRAN NML = N - NRAN R1L = R1 + NRAN GO TO 30 C C *** CONVERGENCE OR LIMIT REACHED *** C 230 IF (L .LE. 0) GO TO 350 IV(COVREQ) = IV(CVRQSV) IV(RDREQ) = IV(RDRQSV) IF (IV(1) .GT. 6) GO TO 360 IF (MOD(IV(RDREQ),4) .EQ. 0) GO TO 360 IF (IV(FDH) .LE. 0 .AND. IABS(IV(COVREQ)) .LT. 3) GO TO 360 IF (IV(REGD) .GT. 0) GO TO 360 IF (IV(COVMAT) .GT. 0) GO TO 360 C C *** PREPARE TO FINISH COMPUTING COVARIANCE MATRIX AND REG. DIAG. *** C PP = L + P I = 0 IF (MOD(IV(RDREQ),4) .GE. 2) I = 1 IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .EQ. 1) I = I+2 IV(MODE) = PP + I I = DR1 + N*PP K = P * (P + 1) / 2 I1 = IV(LMAT) CALL DV7CPY(K, V(I), V(I1)) I = I + K CALL DV7SCP(PP*(PP+1)/2 - K, V(I), ZERO) IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(CNVCOD) = IV(1) IV(IV1SAV) = -1 IV(1) = 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 GO TO 999 C C *** FINISH COVARIANCE COMPUTATION *** C 240 I = DR1 + N*P DO 250 I1 = 1, L CALL DV7SCL(N, V(I), NEGONE, A(1,I1)) I = I + N 250 CONTINUE PP = L + P HSAVE = IV(H) K = DR1 + N*PP LH = PP * (PP + 1) / 2 IF (IABS(IV(COVREQ)) .LT. 3) GO TO 270 I = IV(MODE) - 4 IF (I .GE. PP) GO TO 260 CALL DV7SCP(LH, V(K), ZERO) CALL DQ7RAD(N, N, PP, V, .FALSE., V(K), V(DR1), V) IV(MODE) = I + 8 IV(1) = 2 IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 GO TO 160 C 260 IV(MODE) = I GO TO 300 C 270 PP1 = P + 1 DRI = DR1 + N*P LI = K + P*PP1/2 DO 290 I = PP1, PP DRI1 = DR1 DO 280 I1 = 1, I V(LI) = V(LI) + DD7TPR(N, V(DRI), V(DRI1)) LI = LI + 1 DRI1 = DRI1 + N 280 CONTINUE DRI = DRI + N 290 CONTINUE CALL DL7SRT(PP1, PP, V(K), V(K), I) IF (I .NE. 0) GO TO 310 300 TEMP1 = K + LH T = DL7SVN(PP, V(K), V(TEMP1), V(TEMP1)) IF (T .LE. ZERO) GO TO 310 T = T / DL7SVX(PP, V(K), V(TEMP1), V(TEMP1)) V(RCOND) = T IF (T .GT. DR7MDC(4)) GO TO 320 310 IV(REGD) = -1 IV(COVMAT) = -1 IV(FDH) = -1 GO TO 340 320 IV(H) = TEMP1 IV(FDH) = IABS(HSAVE) IF (IV(MODE) - PP .LT. 2) GO TO 330 I = IV(H) CALL DV7SCP(LH, V(I), ZERO) 330 CALL DN2LRD(V(DR1), IV, V(K), LH, LIV, LV, N, N, PP, V(R1), 1 V(RD1), V) 340 CALL DC7VFN(IV, V(K), LH, LIV, LV, N, PP, V) IV(H) = HSAVE C 350 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1 360 IF (IV(1) .LE. 11) CALL DS7CPR(C, IV, L, LIV) IF (IV(1) .GT. 6) GO TO 999 CALL DN2CVP(IV, LIV, LV, P+L, V) CALL DN2RDP(IV, LIV, LV, N, V(RD1), V) GO TO 999 C 370 IV(1) = 66 CALL DITSUM(V, V, IV, LIV, LV, P, V, ALF) C 999 RETURN C C *** LAST CARD OF DRNSG FOLLOWS *** END SUBROUTINE DRNSGB(A, ALF, B, C, DA, IN, IV, L, L1, LA, LIV, LV, 1 N, NDA, P, V, Y) C C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES, C *** WITH SIMPLE BOUNDS ON THE NONLINEAR VARIABLES. C C *** PARAMETER DECLARATIONS *** C INTEGER L, L1, LA, LIV, LV, N, NDA, P INTEGER IN(2,NDA), IV(LIV) C DIMENSION UIPARM(*) DOUBLE PRECISION A(LA,L1), ALF(P), B(2,P), C(L), DA(LA,NDA), 1 V(LV), Y(N) C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), DRNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) , C I=1 I I C C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS C B(1,I) .LE. ALF(I) .LE. B(2,I), I = 1(1)P. C C THE (L+1)ST TERM IS OPTIONAL. C C C *** PARAMETERS *** C C A (IN) MATRIX PHI(ALF,T) OF THE MODEL. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C C (OUT) LINEAR PARAMETERS (ESTIMATED). C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS C OF ALF, AS SPECIFIED BY THE IN ARRAY... C IN (IN) WHEN DRNSGB IS CALLED WITH IV(1) = 2 OR -2, THEN FOR C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2 C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND C DRNSGB SHOULD RETURN FOR THEM. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. DRNSGB RETURNS C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2 C (AFTER A RETURN WITH IV(1) = 2), DRNSGB RETURNS C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT. C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + 4*P. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + 2*N + L*(L+3)/2 + P*(2*P + 21 + N). C N (IN) NUMBER OF OBSERVATIONS. C NDA (IN) NUMBER OF COLUMNS IN DA AND IN. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C Y (IN) RIGHT-HAND SIDE VECTOR. C C C *** EXTERNAL SUBROUTINES *** C DOUBLE PRECISION DL7SVX, DL7SVN, DR7MDC EXTERNAL DIVSET,DITSUM, DL7ITV, DL7SVX, DL7SVN, DRN2GB, DQ7APL, 1 DQ7RFH, DR7MDC, DS7CPR,DV2AXY,DV7CPY,DV7PRM, DV7SCP C C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C DITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF. C DL7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C DRN2GB... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER. C DQ7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY DQ7RFH. C DQ7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING. C DR7MDC... RETURNS MACHINE-DEP. CONSTANTS. C DS7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION. C DV2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7PRM.... PERMUTES VECTOR. C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER AR1, CSAVE1, D1, DR1, DR1L, I, I1, 1 IPIV1, IER, IV1, J1, JLEN, K, LL1O2, MD, N1, N2, 2 NML, NRAN, R1, R1L, RD1 DOUBLE PRECISION SINGTL, T DOUBLE PRECISION MACHEP, NEGONE, SNGFAC, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AR, CSAVE, D, IERS, IPIVS, IV1SAV, 2 IVNEED, J, MODE, NEXTIV, NEXTV, 2 NFCALL, NFGCAL, PERM, R, 3 REGD, REGD0, RESTOR, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AR/110/, CSAVE/105/, D/27/, IERS/108/, IPIVS/109/, C 1 IV1SAV/104/, IVNEED/3/, J/70/, MODE/35/, NEXTIV/46/, C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, PERM/58/, R/61/, REGD/67/, C 3 REGD0/82/, RESTOR/9/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (AR=110, CSAVE=105, D=27, IERS=108, IPIVS=109, 1 IV1SAV=104, IVNEED=3, J=70, MODE=35, NEXTIV=46, 2 NEXTV=47, NFCALL=6, NFGCAL=7, PERM=58, R=61, REGD=67, 3 REGD0=82, RESTOR=9, TOOBIG=2, VNEED=4) C/ DATA MACHEP/-1.D+0/, NEGONE/-1.D+0/, SNGFAC/1.D+2/, ZERO/0.D+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) N1 = 1 NML = N IV1 = IV(1) IF (IV1 .LE. 2) GO TO 20 C C *** CHECK INPUT INTEGERS *** C IF (P .LE. 0) GO TO 240 IF (L .LT. 0) GO TO 240 IF (N .LE. L) GO TO 240 IF (LA .LT. N) GO TO 240 IF (IV1 .LT. 12) GO TO 20 IF (IV1 .EQ. 14) GO TO 20 IF (IV1 .EQ. 12) IV(1) = 13 C C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS *** C IF (IV(1) .GT. 16) GO TO 240 LL1O2 = L*(L+1)/2 JLEN = N*P I = L + P IF (IV(1) .NE. 13) GO TO 10 IV(IVNEED) = IV(IVNEED) + L IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1 CALL DRN2GB(B, V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IPIVS) = IV(NEXTIV) IV(NEXTIV) = IV(NEXTIV) + L IV(D) = IV(NEXTV) IV(REGD0) = IV(D) + P IV(AR) = IV(REGD0) + N IV(CSAVE) = IV(AR) + LL1O2 IV(J) = IV(CSAVE) + L IV(R) = IV(J) + JLEN IV(NEXTV) = IV(R) + N IV(IERS) = 0 IF (IV1 .EQ. 13) GO TO 999 C C *** SET POINTERS INTO IV AND V *** C 20 AR1 = IV(AR) D1 = IV(D) DR1 = IV(J) DR1L = DR1 + L R1 = IV(R) R1L = R1 + L RD1 = IV(REGD0) CSAVE1 = IV(CSAVE) NML = N - L IF (IV1 .LE. 2) GO TO 50 C 30 N2 = NML CALL DRN2GB(B, V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P, 1 V(R1L), V(RD1), V, ALF) IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0) 1 CALL DV7CPY(L, C, V(CSAVE1)) IV1 = IV(1) IF (IV1-2) 40, 150, 230 C C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED *** C 40 IV(IV1SAV) = IV(1) IV(1) = IABS(IV1) IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL DV7CPY(L, V(CSAVE1), C) GO TO 999 C C *** COMPUTE NEW RESIDUAL OR GRADIENT *** C 50 IV(1) = IV(IV1SAV) MD = IV(MODE) IF (MD .LE. 0) GO TO 60 NML = N DR1L = DR1 R1L = R1 60 IF (IV(TOOBIG) .NE. 0) GO TO 30 IF (IABS(IV1) .EQ. 2) GO TO 170 C C *** COMPUTE NEW RESIDUAL *** C IF (L1 .LE. L) CALL DV7CPY(N, V(R1), Y) IF (L1 .GT. L) CALL DV2AXY(N, V(R1), NEGONE, A(1,L1), Y) IF (MD .GT. 0) GO TO 120 IER = 0 IF (L .LE. 0) GO TO 110 LL1O2 = L * (L + 1) / 2 IPIV1 = IV(IPIVS) CALL DQ7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C) C C *** DETERMINE NUMERICAL RANK OF A *** C IF (MACHEP .LE. ZERO) MACHEP = DR7MDC(3) SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP K = L IF (IER .NE. 0) K = IER - 1 70 IF (K .LE. 0) GO TO 90 T = DL7SVX(K, V(AR1), C, C) IF (T .GT. ZERO) T = DL7SVN(K, V(AR1), C, C) / T IF (T .GT. SINGTL) GO TO 80 K = K - 1 GO TO 70 C C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK, C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1. C 80 IF (K .GE. L) GO TO 100 90 IER = K + 1 CALL DV7SCP(L-K, C(K+1), ZERO) 100 IV(IERS) = IER IF (K .LE. 0) GO TO 110 C C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS... C CALL DQ7APL(LA, N, K, A, V(R1), IER) C C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT C *** THE LAST ITERATION. C CALL DL7ITV(K, C, V(AR1), V(R1)) CALL DV7PRM(L, IV(IPIV1), C) C 110 IF(IV(1) .LT. 2) GO TO 220 GO TO 999 C C C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN *** C 120 IF (L .LE. 0) GO TO 140 DO 130 I = 1, L 130 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1)) 140 IF (IV(1) .GT. 0) GO TO 30 IV(1) = 2 GO TO 160 C C *** NEW GRADIENT (JACOBIAN) NEEDED *** C 150 IV(IV1SAV) = IV1 IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1 160 CALL DV7SCP(N*P, V(DR1), ZERO) GO TO 999 C C *** COMPUTE NEW JACOBIAN *** C 170 IF (NDA .LE. 0) GO TO 240 DO 180 I = 1, NDA I1 = IN(1,I) - 1 IF (I1 .LT. 0) GO TO 180 J1 = IN(2,I) K = DR1 + I1*N T = NEGONE IF (J1 .LE. L) T = -C(J1) CALL DV2AXY(N, V(K), T, DA(1,I), V(K)) 180 CONTINUE IF (IV1 .EQ. 2) GO TO 190 IV(1) = IV1 GO TO 999 190 IF (L .LE. 0) GO TO 30 IF (MD .GT. 0) GO TO 30 K = DR1 IER = IV(IERS) NRAN = L IF (IER .GT. 0) NRAN = IER - 1 IF (NRAN .LE. 0) GO TO 210 DO 200 I = 1, P CALL DQ7APL(LA, N, NRAN, A, V(K), IER) K = K + N 200 CONTINUE 210 CALL DV7CPY(L, V(CSAVE1), C) 220 IF (IER .EQ. 0) GO TO 30 C C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR... C NRAN = IER - 1 DR1L = DR1 + NRAN NML = N - NRAN R1L = R1 + NRAN GO TO 30 C C *** CONVERGENCE OR LIMIT REACHED *** C 230 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1 IF (IV(1) .LE. 11) CALL DS7CPR(C, IV, L, LIV) GO TO 999 C 240 IV(1) = 66 CALL DITSUM(V, V, IV, LIV, LV, P, V, ALF) C 999 RETURN C C *** LAST CARD OF DRNSGB FOLLOWS *** END SUBROUTINE DS3GRD(ALPHA, B, D, ETA0, FX, G, IRC, P, W, X) C C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME *** C C *** PARAMETERS *** C INTEGER IRC, P DOUBLE PRECISION ALPHA(P), B(2,P), D(P), ETA0, FX, G(P), W(6), 1 X(P) C C....................................................................... C C *** PURPOSE *** C C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER- C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY C REVERSE COMMUNICATION. C C *** PARAMETER DESCRIPTION *** C C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X). C B IN ARRAY OF SIMPLE LOWER AND UPPER BOUNDS ON X. X MUST C SATISFY B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P. C FOR ALL I WITH B(1,I) .GE. B(2,I), DS3GRD SIMPLY C SETS G(I) TO 0. C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,P, ARE IN C COMPARABLE UNITS. C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE... C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE C ABS(E) .LE. ETA0. C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL C VALUE, THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH C IRC = 0. C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE C PREVIOUS ITERATE. WHEN DS3GRD RETURNS WITH IRC = 0, G IS C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE C GRADIENT AT X. C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS3GRD, C THE CALLER MUST SET IRC TO 0. WHENEVER DS3GRD RETURNS A C NONZERO VALUE (OF AT MOST P) FOR IRC, IT HAS PERTURBED C SOME COMPONENT OF X... THE CALLER SHOULD EVALUATE F(X) C AND CALL DS3GRD AGAIN WITH FX = F(X). IF B PREVENTS C ESTIMATING G(I) I.E., IF THERE IS AN I WITH C B(1,I) .LT. B(2,I) BUT WITH B(1,I) SO CLOSE TO B(2,I) C THAT THE FINITE-DIFFERENCING STEPS CANNOT BE CHOSEN, C THEN DS3GRD RETURNS WITH IRC .GT. P. C P IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F C DEPENDS. C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE C (THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH IRC = 0) C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION. C W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS3GRD SAVES CERTAIN C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A C PERTURBED X. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION). C C *** ALGORITHM NOTES *** C C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1) C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980). C C *** GENERAL *** C C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND C MCS-7906671. C C....................................................................... C C ***** EXTERNAL FUNCTION ***** C DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C C ***** INTRINSIC FUNCTIONS ***** C/+ DOUBLE PRECISION DSQRT C/ C ***** LOCAL VARIABLES ***** C LOGICAL HIT INTEGER FH, FX0, HSAVE, I, XISAVE DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR, 1 DISCON, ETA, GI, H, HMIN, XI, XIH DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002, 1 THREE, TWO, ZERO C C/6 C DATA C2000/2.0D+3/, FOUR/4.0D+0/, HMAX0/0.02D+0/, HMIN0/5.0D+1/, C 1 ONE/1.0D+0/, P002/0.002D+0/, THREE/3.0D+0/, C 2 TWO/2.0D+0/, ZERO/0.0D+0/ C/7 PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1, 1 ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0, 2 TWO=2.0D+0, ZERO=0.0D+0) C/ C/6 C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/ C/7 PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C/ C C--------------------------------- BODY ------------------------------ C IF (IRC) 80, 10, 210 C C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS *** C C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE C SQUARE-ROOT OF MACHEP. C 10 W(1) = DR7MDC(3) W(2) = DSQRT(W(1)) C W(FX0) = FX C C *** INCREMENT I AND START COMPUTING G(I) *** C 20 I = IABS(IRC) + 1 IF (I .GT. P) GO TO 220 IRC = I IF (B(1,I) .LT. B(2,I)) GO TO 30 G(I) = ZERO GO TO 20 30 AFX = DABS(W(FX0)) MACHEP = W(1) H0 = W(2) HMIN = HMIN0 * MACHEP XI = X(I) W(XISAVE) = XI AXI = DABS(XI) AXIBAR = DMAX1(AXI, ONE/D(I)) GI = G(I) AGI = DABS(GI) ETA = DABS(ETA0) IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX) ALPHAI = ALPHA(I) IF (ALPHAI .EQ. ZERO) GO TO 130 IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 140 AFXETA = AFX*ETA AAI = DABS(ALPHAI) C C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE. C IF (GI**2 .LE. AFXETA*AAI) GO TO 40 H = TWO*DSQRT(AFXETA/AAI) H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI)) GO TO 50 C40 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE) 40 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE) H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI)) C C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL *** C 50 H = DMAX1(H, HMIN*AXIBAR) C C *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT C *** MOST 10**-3. C IF (AAI*H .LE. P002*AGI) GO TO 120 C C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE. C DISCON = C2000*AFXETA H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON)) C C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG *** C H = DMAX1(H, HMIN*AXIBAR) IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE) C C *** COMPUTE CENTRAL DIFFERENCE *** C XIH = XI + H IF (XI - H .LT. B(1,I)) GO TO 60 IRC = -I IF (XIH .LE. B(2,I)) GO TO 200 H = -H XIH = XI + H IF (XI + TWO*H .LT. B(1,I)) GO TO 190 GO TO 70 60 IF (XI + TWO*H .GT. B(2,I)) GO TO 190 C *** MUST DO OFF-SIDE CENTRAL DIFFERENCE *** 70 IRC = -(I + P) GO TO 200 C 80 I = -IRC IF (I .LE. P) GO TO 100 I = I - P IF (I .GT. P) GO TO 90 W(FH) = FX H = TWO * W(HSAVE) XIH = W(XISAVE) + H IRC = IRC - P GO TO 200 C C *** FINISH OFF-SIDE CENTRAL DIFFERENCE *** C 90 I = I - P G(I) = (FOUR*W(FH) - FX - THREE*W(FX0)) / W(HSAVE) IRC = I X(I) = W(XISAVE) GO TO 20 C 100 H = -W(HSAVE) IF (H .GT. ZERO) GO TO 110 W(FH) = FX XIH = W(XISAVE) + H GO TO 200 C 110 G(I) = (W(FH) - FX) / (TWO * H) X(I) = W(XISAVE) GO TO 20 C C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES *** C 120 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR IF (ALPHAI*GI .LT. ZERO) H = -H GO TO 150 130 H = AXIBAR GO TO 150 140 H = H0 * AXIBAR C 150 HIT = .FALSE. 160 XIH = XI + H IF (H .GT. ZERO) GO TO 170 IF (XIH .GE. B(1,I)) GO TO 200 GO TO 180 170 IF (XIH .LE. B(2,I)) GO TO 200 180 IF (HIT) GO TO 190 HIT = .TRUE. H = -H GO TO 160 C C *** ERROR RETURN... 190 IRC = I + P GO TO 230 C C *** RETURN FOR NEW FUNCTION VALUE... 200 X(I) = XIH W(HSAVE) = H GO TO 999 C C *** COMPUTE ACTUAL FORWARD DIFFERENCE *** C 210 G(IRC) = (FX - W(FX0)) / W(HSAVE) X(IRC) = W(XISAVE) GO TO 20 C C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED *** C 220 IRC = 0 230 FX = W(FX0) C 999 RETURN C *** LAST LINE OF DS3GRD FOLLOWS *** END SUBROUTINE DS7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS, 1 P, P1, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE BOUNDED MODIFIED NEWTON STEP *** C INTEGER KB, LV, NS, P, P1 INTEGER IPIV(P), IPIV1(P), IPIV2(P) DOUBLE PRECISION B(2,P), D(P), DST(P), L(1), 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P), 2 X0(P) C DIMENSION L(P*(P+1)/2) C DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM EXTERNAL DD7TPR, I7SHFT, DL7ITV, DL7IVM, DQ7RSH, DR7MDC, DV2NRM, 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7SHF C C *** LOCAL VARIABLES *** C INTEGER I, J, K, P0, P1M1 DOUBLE PRECISION ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T, 1 TI, T1, XI DOUBLE PRECISION FUDGE, HALF, MEPS2, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR C C/6 C DATA DSTNRM/2/, GTSTEP/4/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, C 1 RADIUS/8/, STPPAR/5/ C/7 PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7, 1 RADIUS=8, STPPAR=5) SAVE MEPS2 C/ C DATA FUDGE/1.0001D+0/, HALF/0.5D+0/, MEPS2/0.D+0/, 1 ONE/1.0D+0/, TWO/2.D+0/, ZERO/0.D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C DSTMAX = FUDGE * (ONE + V(PHMXFC)) * V(RADIUS) DSTMIN = (ONE + V(PHMNFC)) * V(RADIUS) DST1 = ZERO IF (MEPS2 .LE. ZERO) MEPS2 = TWO * DR7MDC(3) P0 = P1 NS = 0 DO 10 I = 1, P IPIV1(I) = I IPIV2(I) = I 10 CONTINUE DO 20 I = 1, P1 20 W(I) = -STEP(I) * TD(I) ALPHA = DABS(V(STPPAR)) V(PREDUC) = ZERO GTS = -V(GTSTEP) IF (KB .LT. 0) CALL DV7SCP(P, DST, ZERO) KB = 1 C C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D. C C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE. C 30 T = ONE K = 0 DO 60 I = 1, P1 J = IPIV(I) DX = W(I) / D(J) XI = X(J) - DX IF (XI .LT. B(1,J)) GO TO 40 IF (XI .LE. B(2,J)) GO TO 60 TI = ( X(J) - B(2,J) ) / DX K = I GO TO 50 40 TI = ( X(J) - B(1,J) ) / DX K = -I 50 IF (T .LE. TI) GO TO 60 T = TI 60 CONTINUE C IF (P .GT. P1) CALL DV7CPY(P-P1, STEP(P1+1), DST(P1+1)) CALL DV2AXY(P1, STEP, -T, W, DST) DST0 = DST1 DST1 = DV2NRM(P, STEP) C C *** CHECK FOR OVERSIZE STEP *** C IF (DST1 .LE. DSTMAX) GO TO 80 IF (P1 .GE. P0) GO TO 70 IF (DST0 .LT. DSTMIN) KB = 0 GO TO 110 C 70 K = 0 C C *** UPDATE DST, TG, AND V(PREDUC) *** C 80 V(DSTNRM) = DST1 CALL DV7CPY(P1, DST, STEP) T1 = ONE - T DO 90 I = 1, P1 90 TG(I) = T1 * TG(I) IF (ALPHA .GT. ZERO) CALL DV2AXY(P1, TG, T*ALPHA, W, TG) V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS + 1 HALF*ALPHA*T*DD7TPR(P1,W,W)) IF (K .EQ. 0) GO TO 110 C C *** PERMUTE L, ETC. IF NECESSARY *** C P1M1 = P1 - 1 J = IABS(K) IF (J .EQ. P1) GO TO 100 NS = NS + 1 IPIV2(P1) = J CALL DQ7RSH(J, P1, .FALSE., TG, L, W) CALL I7SHFT(P1, J, IPIV) CALL I7SHFT(P1, J, IPIV1) CALL DV7SHF(P1, J, TG) CALL DV7SHF(P1, J, DST) 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1) P1 = P1M1 IF (P1 .LE. 0) GO TO 110 CALL DL7IVM(P1, W, L, TG) GTS = DD7TPR(P1, W, W) CALL DL7ITV(P1, W, L, W) GO TO 30 C C *** UNSCALE STEP *** C 110 DO 120 I = 1, P J = IABS(IPIV(I)) STEP(J) = DST(I) / D(J) 120 CONTINUE C C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS C *** TO THEIR BOUNDS *** C IF (P1 .GE. P0) GO TO 150 K = P1 + 1 DO 140 I = K, P0 J = IPIV(I) T = MEPS2 IF (J .GT. 0) GO TO 130 T = -T J = -J IPIV(I) = J 130 T = T * DMAX1(DABS(X(J)), DABS(X0(J))) STEP(J) = STEP(J) + T 140 CONTINUE C 150 CALL DV2AXY(P, X, ONE, STEP, X0) IF (NS .GT. 0) CALL DV7IPR(P0, IPIV1, TD) 999 RETURN C *** LAST LINE OF DS7BQN FOLLOWS *** END SUBROUTINE DS7CPR(C, IV, L, LIV) C C *** PRINT C FOR DNSG (ETC.) *** C INTEGER L, LIV INTEGER IV(LIV) DOUBLE PRECISION C(L) C INTEGER I, PU C INTEGER PRUNIT, SOLPRT C C/6 C DATA PRUNIT/21/, SOLPRT/22/ C/7 PARAMETER (PRUNIT=21, SOLPRT=22) C/ C *** BODY *** C IF (IV(1) .GT. 11) GO TO 999 IF (IV(SOLPRT) .EQ. 0) GO TO 999 PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (L .GT. 0) WRITE(PU,10) (I, C(I), I = 1, L) 10 FORMAT(/21H LINEAR PARAMETERS...//(1X,I5,D16.6)) C 999 RETURN C *** LAST LINE OF DS7CPR FOLLOWS *** END SUBROUTINE DS7DMP(N, X, Y, Z, K) C C *** SET X = DIAG(Z)**K * Y * DIAG(Z)**K C *** FOR X, Y = COMPACTLY STORED LOWER TRIANG. MATRICES C *** K = 1 OR -1. C INTEGER N, K C/6S C DOUBLE PRECISION X(1), Y(1), Z(N) C/7S DOUBLE PRECISION X(*), Y(*), Z(N) C/ INTEGER I, J, L DOUBLE PRECISION ONE, T DATA ONE/1.D+0/ C L = 1 IF (K .GE. 0) GO TO 30 DO 20 I = 1, N T = ONE / Z(I) DO 10 J = 1, I X(L) = T * Y(L) / Z(J) L = L + 1 10 CONTINUE 20 CONTINUE GO TO 999 C 30 DO 50 I = 1, N T = Z(I) DO 40 J = 1, I X(L) = T * Y(L) * Z(J) L = L + 1 40 CONTINUE 50 CONTINUE 999 RETURN C *** LAST CARD OF DS7DMP FOLLOWS *** END SUBROUTINE DS7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X) C C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME *** C C *** PARAMETERS *** C INTEGER IRC, N DOUBLE PRECISION ALPHA(N), D(N), ETA0, FX, G(N), W(6), X(N) C C....................................................................... C C *** PURPOSE *** C C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER- C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY C REVERSE COMMUNICATION. C C *** PARAMETER DESCRIPTION *** C C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X). C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,N, ARE IN C COMPARABLE UNITS. C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE... C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE C ABS(E) .LE. ETA0. C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL C VALUE, THE ONE IT HAD WHEN DS7GRD WAS LAST CALLED WITH C IRC = 0. C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE C PREVIOUS ITERATE. WHEN DS7GRD RETURNS WITH IRC = 0, G IS C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE C GRADIENT AT X. C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS7GRD, C THE CALLER MUST SET IRC TO 0. WHENEVER DS7GRD RETURNS A C NONZERO VALUE FOR IRC, IT HAS PERTURBED SOME COMPONENT OF C X... THE CALLER SHOULD EVALUATE F(X) AND CALL DS7GRD C AGAIN WITH FX = F(X). C N IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F C DEPENDS. C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE C (THE ONE IT HAD WHEN DS7GRD WAS LAST CALLED WITH IRC = 0) C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION. C W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS7GRD SAVES CERTAIN C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A C PERTURBED X. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION). C C *** ALGORITHM NOTES *** C C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1) C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980). C C *** GENERAL *** C C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND C MCS-7906671. C C....................................................................... C C ***** EXTERNAL FUNCTION ***** C DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C C ***** INTRINSIC FUNCTIONS ***** C/+ DOUBLE PRECISION DSQRT C/ C ***** LOCAL VARIABLES ***** C INTEGER FH, FX0, HSAVE, I, XISAVE DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR, 1 DISCON, ETA, GI, H, HMIN DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002, 1 THREE, TWO, ZERO C C/6 C DATA C2000/2.0D+3/, FOUR/4.0D+0/, HMAX0/0.02D+0/, HMIN0/5.0D+1/, C 1 ONE/1.0D+0/, P002/0.002D+0/, THREE/3.0D+0/, C 2 TWO/2.0D+0/, ZERO/0.0D+0/ C/7 PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1, 1 ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0, 2 TWO=2.0D+0, ZERO=0.0D+0) C/ C/6 C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/ C/7 PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C/ C C--------------------------------- BODY ------------------------------ C IF (IRC) 140, 100, 210 C C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS *** C C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE C SQUARE-ROOT OF MACHEP. C 100 W(1) = DR7MDC(3) W(2) = DSQRT(W(1)) C W(FX0) = FX C C *** INCREMENT I AND START COMPUTING G(I) *** C 110 I = IABS(IRC) + 1 IF (I .GT. N) GO TO 300 IRC = I AFX = DABS(W(FX0)) MACHEP = W(1) H0 = W(2) HMIN = HMIN0 * MACHEP W(XISAVE) = X(I) AXI = DABS(X(I)) AXIBAR = DMAX1(AXI, ONE/D(I)) GI = G(I) AGI = DABS(GI) ETA = DABS(ETA0) IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX) ALPHAI = ALPHA(I) IF (ALPHAI .EQ. ZERO) GO TO 170 IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 180 AFXETA = AFX*ETA AAI = DABS(ALPHAI) C C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE. C IF (GI**2 .LE. AFXETA*AAI) GO TO 120 H = TWO*DSQRT(AFXETA/AAI) H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI)) GO TO 130 C120 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE) 120 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE) H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI)) C C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL *** C 130 H = DMAX1(H, HMIN*AXIBAR) C C *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT C *** MOST 10**-3. C IF (AAI*H .LE. P002*AGI) GO TO 160 C C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE. C DISCON = C2000*AFXETA H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON)) C C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG *** C H = DMAX1(H, HMIN*AXIBAR) IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE) C C *** COMPUTE CENTRAL DIFFERENCE *** C IRC = -I GO TO 200 C 140 H = -W(HSAVE) I = IABS(IRC) IF (H .GT. ZERO) GO TO 150 W(FH) = FX GO TO 200 C 150 G(I) = (W(FH) - FX) / (TWO * H) X(I) = W(XISAVE) GO TO 110 C C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES *** C 160 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR IF (ALPHAI*GI .LT. ZERO) H = -H GO TO 200 170 H = AXIBAR GO TO 200 180 H = H0 * AXIBAR C 200 X(I) = W(XISAVE) + H W(HSAVE) = H GO TO 999 C C *** COMPUTE ACTUAL FORWARD DIFFERENCE *** C 210 G(IRC) = (FX - W(FX0)) / W(HSAVE) X(IRC) = W(XISAVE) GO TO 110 C C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED *** C 300 FX = W(FX0) IRC = 0 C 999 RETURN C *** LAST CARD OF DS7GRD FOLLOWS *** END SUBROUTINE DS7IPR(P, IP, H) C C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H. C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)). C INTEGER P INTEGER IP(P) DOUBLE PRECISION H(1) C INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M DOUBLE PRECISION T C C *** BODY *** C DO 90 I = 1, P J = IP(I) IF (J .EQ. I) GO TO 90 IP(I) = IABS(J) IF (J .LT. 0) GO TO 90 K = I 10 J1 = J K1 = K IF (J .LE. K) GO TO 20 J1 = K K1 = J 20 KMJ = K1-J1 L = J1-1 JM = J1*L/2 KM = K1*(K1-1)/2 IF (L .LE. 0) GO TO 40 DO 30 M = 1, L JM = JM+1 T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 30 CONTINUE 40 KM = KM+1 KK = KM+KMJ JM = JM+1 T = H(JM) H(JM) = H(KK) H(KK) = T J1 = L L = KMJ-1 IF (L .LE. 0) GO TO 60 DO 50 M = 1, L JM = JM+J1+M T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 50 CONTINUE 60 IF (K1 .GE. P) GO TO 80 L = P-K1 K1 = K1-1 KM = KK DO 70 M = 1, L KM = KM+K1+M JM = KM-KMJ T = H(JM) H(JM) = H(KM) H(KM) = T 70 CONTINUE 80 K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 10 90 CONTINUE 999 RETURN C *** LAST LINE OF DS7IPR FOLLOWS *** END SUBROUTINE DS7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, 1 Y) C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P), 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, J, K DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** DOUBLE PRECISION HALF, ONE, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DD7TPR, DS7LVM, DV2NRM C C/6 C DATA HALF/0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ C/7 PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C----------------------------------------------------------------------- C SDOTWM = DD7TPR(P, STEP, WCHMTD) DENMIN = COSMIN * DV2NRM(P,STEP) * DV2NRM(P,WCHMTD) WSCALE = ONE IF (DENMIN .NE. ZERO) WSCALE = DMIN1(ONE, DABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL DS7LVM(P, U, A, STEP) T = HALF * (SIZE * DD7TPR(P, STEP, U) - DD7TPR(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF DS7LUP FOLLOWS *** END SUBROUTINE DS7LVM(P, Y, S, X) C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, J, K DOUBLE PRECISION XI C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTION *** C DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR C C----------------------------------------------------------------------- C J = 1 DO 10 I = 1, P Y(I) = DD7TPR(I, S(J), X) J = J + I 10 CONTINUE C IF (P .LE. 1) GO TO 999 J = 1 DO 40 I = 2, P XI = X(I) IM1 = I - 1 J = J + 1 DO 30 K = 1, IM1 Y(K) = Y(K) + S(J)*XI J = J + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF DS7LVM FOLLOWS *** END SUBROUTINE DSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP, * INFO,IPNTR,JPNTR,IWA,LIWA,BWA) INTEGER M,N,NPAIRS,MAXGRP,MINGRP,INFO,LIWA INTEGER INDROW(NPAIRS),INDCOL(NPAIRS),NGRP(N), * IPNTR(1),JPNTR(1),IWA(LIWA) LOGICAL BWA(N) C ********** C C SUBROUTINE DSM C C THE PURPOSE OF DSM IS TO DETERMINE AN OPTIMAL OR NEAR- C OPTIMAL CONSISTENT PARTITION OF THE COLUMNS OF A SPARSE C M BY N MATRIX A. C C THE SPARSITY PATTERN OF THE MATRIX A IS SPECIFIED BY C THE ARRAYS INDROW AND INDCOL. ON INPUT THE INDICES C FOR THE NON-ZERO ELEMENTS OF A ARE C C INDROW(K),INDCOL(K), K = 1,2,...,NPAIRS. C C THE (INDROW,INDCOL) PAIRS MAY BE SPECIFIED IN ANY ORDER. C DUPLICATE INPUT PAIRS ARE PERMITTED, BUT THE SUBROUTINE C ELIMINATES THEM. C C THE SUBROUTINE PARTITIONS THE COLUMNS OF A INTO GROUPS C SUCH THAT COLUMNS IN THE SAME GROUP DO NOT HAVE A C NON-ZERO IN THE SAME ROW POSITION. A PARTITION OF THE C COLUMNS OF A WITH THIS PROPERTY IS CONSISTENT WITH THE C DIRECT DETERMINATION OF A. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE DSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP, C INFO,IPNTR,JPNTR,IWA,LIWA,BWA) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C NPAIRS IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE C NUMBER OF (INDROW,INDCOL) PAIRS USED TO DESCRIBE THE C SPARSITY PATTERN OF A. C C INDROW IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDROW C MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A. C ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING C COLUMN INDICES ARE IN NON-DECREASING ORDER. THE COLUMN C INDICES CAN BE RECOVERED FROM THE ARRAY JPNTR. C C INDCOL IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDCOL C MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS OF C A. ON OUTPUT INDCOL IS PERMUTED SO THAT THE CORRESPONDING C ROW INDICES ARE IN NON-DECREASING ORDER. THE ROW INDICES C CAN BE RECOVERED FROM THE ARRAY IPNTR. C C NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS C TO GROUP NGRP(JCOL). C C MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE C NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A. C C MINGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES A LOWER C BOUND FOR THE NUMBER OF GROUPS IN ANY CONSISTENT PARTITION C OF THE COLUMNS OF A. C C INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS. FOR C NORMAL TERMINATION INFO = 1. IF M, N, OR NPAIRS IS NOT C POSITIVE OR LIWA IS LESS THAN MAX(M,6*N), THEN INFO = 0. C IF THE K-TH ELEMENT OF INDROW IS NOT AN INTEGER BETWEEN C 1 AND M OR THE K-TH ELEMENT OF INDCOL IS NOT AN INTEGER C BETWEEN 1 AND N, THEN INFO = -K. C C IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. C THE COLUMN INDICES FOR ROW I ARE C C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. C C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. C THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C IWA IS AN INTEGER WORK ARRAY OF LENGTH LIWA. C C LIWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN C MAX(M,6*N). C C BWA IS A LOGICAL WORK ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ...D7EGR,I7DO,N7MSRT,M7SEQ,S7ETR,M7SLO,S7RTDT C C FORTRAN-SUPPLIED ... MAX0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER I,IR,J,JP,JPL,JPU,K,MAXCLQ,NNZ,NUMGRP C C CHECK THE INPUT DATA. C INFO = 0 IF (M .LT. 1 .OR. N .LT. 1 .OR. NPAIRS .LT. 1 .OR. * LIWA .LT. MAX0(M,6*N)) GO TO 130 DO 10 K = 1, NPAIRS INFO = -K IF (INDROW(K) .LT. 1 .OR. INDROW(K) .GT. M .OR. * INDCOL(K) .LT. 1 .OR. INDCOL(K) .GT. N) GO TO 130 10 CONTINUE INFO = 1 C C SORT THE DATA STRUCTURE BY COLUMNS. C CALL S7RTDT(N,NPAIRS,INDROW,INDCOL,JPNTR,IWA(1)) C C COMPRESS THE DATA AND DETERMINE THE NUMBER OF C NON-ZERO ELEMENTS OF A. C DO 20 I = 1, M IWA(I) = 0 20 CONTINUE NNZ = 0 DO 70 J = 1, N JPL = JPNTR(J) JPU = JPNTR(J+1) - 1 JPNTR(J) = NNZ + 1 IF (JPU .LT. JPL) GO TO 60 DO 40 JP = JPL, JPU IR = INDROW(JP) IF (IWA(IR) .NE. 0) GO TO 30 NNZ = NNZ + 1 INDROW(NNZ) = IR IWA(IR) = 1 30 CONTINUE 40 CONTINUE JPL = JPNTR(J) DO 50 JP = JPL, NNZ IR = INDROW(JP) IWA(IR) = 0 50 CONTINUE 60 CONTINUE 70 CONTINUE JPNTR(N+1) = NNZ + 1 C C EXTEND THE DATA STRUCTURE TO ROWS. C CALL S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(1)) C C DETERMINE A LOWER BOUND FOR THE NUMBER OF GROUPS. C MINGRP = 0 DO 80 I = 1, M MINGRP = MAX0(MINGRP,IPNTR(I+1)-IPNTR(I)) 80 CONTINUE C C DETERMINE THE DEGREE SEQUENCE FOR THE INTERSECTION C GRAPH OF THE COLUMNS OF A. C CALL D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(N+1),BWA) C C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A C WITH THE SMALLEST-LAST (SL) ORDERING. C CALL M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1), * MAXCLQ,IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1),BWA) CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),NGRP,MAXGRP, * IWA(N+1),BWA) MINGRP = MAX0(MINGRP,MAXCLQ) IF (MAXGRP .EQ. MINGRP) GO TO 130 C C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A C WITH THE INCIDENCE-DEGREE (ID) ORDERING. C CALL I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1), * MAXCLQ,IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1),BWA) CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP, * IWA(N+1),BWA) MINGRP = MAX0(MINGRP,MAXCLQ) IF (NUMGRP .GE. MAXGRP) GO TO 100 MAXGRP = NUMGRP DO 90 J = 1, N NGRP(J) = IWA(J) 90 CONTINUE IF (MAXGRP .EQ. MINGRP) GO TO 130 100 CONTINUE C C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A C WITH THE LARGEST-FIRST (LF) ORDERING. C CALL N7MSRT(N,N-1,IWA(5*N+1),-1,IWA(4*N+1),IWA(2*N+1),IWA(N+1)) CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP, * IWA(N+1),BWA) IF (NUMGRP .GE. MAXGRP) GO TO 120 MAXGRP = NUMGRP DO 110 J = 1, N NGRP(J) = IWA(J) 110 CONTINUE 120 CONTINUE C C EXIT FROM PROGRAM. C 130 CONTINUE RETURN C C LAST CARD OF SUBROUTINE DSM. C END SUBROUTINE DSMNFB(P, X, B, CALCF, MXFCAL, ACC ) C C ** SIMPLIED VERSION OF DMNF C C INPUT PARAMETERS C P NUMBER OF UNKNOWNS C X APPROXIMATE SOLUTION C B FIRST ROW OF B GIVES LOWER BOUNDS ON X AND SECOND GIVES UPPER C BOUNDS C CALCF SUBROUTINE TO EVALUATE FUNCTION C MXFCAL MAXIMUM NUMBER OF PERMITTED FUNCTION EVALUATIONS C ACC ACCURACY IN X C OUTPUT PARAMETERS C X SOLUTION INTEGER P, MXFCAL DOUBLE PRECISION X(P), ACC ,B(2,P) EXTERNAL CALCF, DC6LCF C C C C *** LOCAL VARIABLES *** C INTEGER IV, LIV, LV, V1 INTEGER IDI,IDM1,ID,J DOUBLE PRECISION UR DOUBLE PRECISION DSTAK(500) COMMON /CSTAK/ DSTAK INTEGER ISTAK(1000) EQUIVALENCE (DSTAK(1), ISTAK(1)) C C *** BODY *** C CALL ENTER(0) C/6S C IF (P.LT.1) C 1CALL SETERR(14HDSMNFB- P.LT.1,14,1,2) C IF (MXFCAL.LT.1) C 1CALL SETERR(19HDSMNFB- MXFCAL.LT.1,19,2,2) C IF (ACC.LT.0.0D0) C 1CALL SETERR(18HDSMNFB-ACC .LT.0.0,18,3,2) C/7S IF (P.LT.1) 1CALL SETERR('DSMNFB- P.LT.1',14,1,2) IF (MXFCAL.LT.1) 1CALL SETERR('DSMNFB- MXFCAL.LT.1',19,2,2) IF (ACC.LT.0.0D0) 1CALL SETERR('DSMNFB-ACC .LT.0.0',18,3,2) C/ LIV =59+P LV=77+P*(P+23)/2 IV=ISTKGT(LIV,2) V1=ISTKGT(LV, 4) CALL DIVSET(2,ISTAK(IV),LIV,LV,DSTAK(V1)) ISTAK(IV+20)=0 ISTAK(IV+16)=MXFCAL ISTAK(IV+17)=MXFCAL DSTAK(V1+32)=ACC DSTAK(V1+31)=ACC ID=ISTKGT(P, 4) IDM1=ID-1 DO 10 I=1,P IDI=IDM1+I DSTAK(IDI)=1.0 IF (X(I).NE.0.0)DSTAK(IDI)=1.0/DABS(X(I)) 10 CONTINUE CALL DMNFB( P, DSTAK(ID),X,B, DC6LCF, ISTAK(IV), LIV, LV, 1 DSTAK(V1), IU, UR, CALCF) J=ISTAK(IV) IF(J.LT.7) GO TO 20 C/6S C IF (J.EQ.82)CALL SETERR(26HDSMNFB-INCONSISTENT BOUNDS,26,4,1) C IF (J.EQ.7)CALL SETERR(27HDSMNFB-SINGULAR CONVERGENCE,27,5,1) C IF(J.EQ.8)CALL SETERR(24HDSMNFB-FALSE CONVERGENCE,24,6,1) C IF(J.EQ.9)CALL SETERR(32HDSMNFB-FUNCTION EVALUATION LIMIT,32,7,1) C IF (J.EQ.63) C 1CALL SETERR(43HDSMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X,43,8,1) C/7S IF (J.EQ.82)CALL SETERR('DSMNFB-INCONSISTENT BOUNDS',26,4,1) IF (J.EQ.7)CALL SETERR('DSMNFB-SINGULAR CONVERGENCE',27,5,1) IF(J.EQ.8)CALL SETERR('DSMNFB-FALSE CONVERGENCE',24,6,1) IF(J.EQ.9)CALL SETERR('DSMNFB-FUNCTION EVALUATION LIMIT',32,7,1) IF (J.EQ.63) 1CALL SETERR('DSMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X',43,8,1) C/ 20 CALL LEAVE C RETURN C *** LAST LINE OF DSMNFB FOLLOWS *** END SUBROUTINE DV2AXY(P, W, A, X, Y) C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C INTEGER P DOUBLE PRECISION A, W(P), X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END DOUBLE PRECISION FUNCTION DV2NRM(P, X) C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C INTEGER P DOUBLE PRECISION X(P) C INTEGER I, J DOUBLE PRECISION ONE, R, SCALE, SQTETA, T, XI, ZERO C/+ DOUBLE PRECISION DSQRT C/ DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C C/6 C DATA ONE/1.D+0/, ZERO/0.D+0/ C/7 PARAMETER (ONE=1.D+0, ZERO=0.D+0) SAVE SQTETA C/ DATA SQTETA/0.D+0/ C IF (P .GT. 0) GO TO 10 DV2NRM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE DV2NRM = ZERO GO TO 999 C 30 SCALE = DABS(X(I)) IF (I .LT. P) GO TO 40 DV2NRM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = DR7MDC(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = DABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C DV2NRM = SCALE * DSQRT(T) 999 RETURN C *** LAST LINE OF DV2NRM FOLLOWS *** END SUBROUTINE DV7CPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C INTEGER P DOUBLE PRECISION X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) RETURN END SUBROUTINE DV7DFL(ALG, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER ALG, LV DOUBLE PRECISION V(LV) C DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS C DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR V *** C INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC, 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ, HUBERC, 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX, 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2, 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL C C/6 C DATA ONE/1.D+0/, THREE/3.D+0/ C/7 PARAMETER (ONE=1.D+0, THREE=3.D+0) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA AFCTOL/31/, BIAS/43/, COSMIN/47/, DECFAC/22/, DELTA0/44/, C 1 DFAC/41/, DINIT/38/, DLTFDC/42/, DLTFDJ/43/, DTINIT/39/, C 2 D0INIT/40/, EPSLON/19/, ETA0/42/, FUZZ/45/, HUBERC/48/, C 3 INCFAC/23/, LMAX0/35/, LMAXS/36/, PHMNFC/20/, PHMXFC/21/, C 4 RDFCMN/24/, RDFCMX/25/, RFCTOL/32/, RLIMIT/46/, RSPTOL/49/, C 5 SCTOL/37/, SIGMIN/50/, TUNER1/26/, TUNER2/27/, TUNER3/28/, C 6 TUNER4/29/, TUNER5/30/, XCTOL/33/, XFTOL/34/ C/7 PARAMETER (AFCTOL=31, BIAS=43, COSMIN=47, DECFAC=22, DELTA0=44, 1 DFAC=41, DINIT=38, DLTFDC=42, DLTFDJ=43, DTINIT=39, 2 D0INIT=40, EPSLON=19, ETA0=42, FUZZ=45, HUBERC=48, 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21, 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49, 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28, 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34) C/ C C------------------------------- BODY -------------------------------- C MACHEP = DR7MDC(3) V(AFCTOL) = 1.D-20 IF (MACHEP .GT. 1.D-10) V(AFCTOL) = MACHEP**2 V(DECFAC) = 0.5D+0 SQTEPS = DR7MDC(4) V(DFAC) = 0.6D+0 V(DTINIT) = 1.D-6 MEPCRT = MACHEP ** (ONE/THREE) V(D0INIT) = 1.D+0 V(EPSLON) = 0.1D+0 V(INCFAC) = 2.D+0 V(LMAX0) = 1.D+0 V(LMAXS) = 1.D+0 V(PHMNFC) = -0.1D+0 V(PHMXFC) = 0.1D+0 V(RDFCMN) = 0.1D+0 V(RDFCMX) = 4.D+0 V(RFCTOL) = DMAX1(1.D-10, MEPCRT**2) V(SCTOL) = V(RFCTOL) V(TUNER1) = 0.1D+0 V(TUNER2) = 1.D-4 V(TUNER3) = 0.75D+0 V(TUNER4) = 0.5D+0 V(TUNER5) = 0.75D+0 V(XCTOL) = SQTEPS V(XFTOL) = 1.D+2 * MACHEP C IF (ALG .GE. 2) GO TO 10 C C *** REGRESSION VALUES C V(COSMIN) = DMAX1(1.D-6, 1.D+2 * MACHEP) V(DINIT) = 0.D+0 V(DELTA0) = SQTEPS V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(FUZZ) = 1.5D+0 V(HUBERC) = 0.7D+0 V(RLIMIT) = DR7MDC(5) V(RSPTOL) = 1.D-3 V(SIGMIN) = 1.D-4 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 V(BIAS) = 0.8D+0 V(DINIT) = -1.0D+0 V(ETA0) = 1.0D+3 * MACHEP C 999 RETURN C *** LAST CARD OF DV7DFL FOLLOWS *** END SUBROUTINE DV7IPR(N, IP, X) C C PERMUTE X SO THAT X.OUTPUT(I) = X.INPUT(IP(I)). C IP IS UNCHANGED ON OUTPUT. C INTEGER N INTEGER IP(N) DOUBLE PRECISION X(N) C INTEGER I, J, K DOUBLE PRECISION T DO 30 I = 1, N J = IP(I) IF (J .EQ. I) GO TO 30 IF (J .GT. 0) GO TO 10 IP(I) = -J GO TO 30 10 T = X(I) K = I 20 X(K) = X(J) K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 20 X(K) = T 30 CONTINUE 999 RETURN C *** LAST LINE OF DV7IPR FOLLOWS *** END SUBROUTINE DV7PRM(N, IP, X) C C PERMUTE X SO THAT X.OUTPUT(IP(I)) = X.INPUT(I). C IP IS UNCHANGED ON OUTPUT. C INTEGER N INTEGER IP(N) DOUBLE PRECISION X(N) C INTEGER I, J, K DOUBLE PRECISION S, T DO 30 I = 1, N J = IP(I) IF (J .EQ. I) GO TO 30 IF (J .GT. 0) GO TO 10 IP(I) = -J GO TO 30 10 T = X(I) 20 S = X(J) X(J) = T T = S K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 20 X(J) = T 30 CONTINUE 999 RETURN C *** LAST LINE OF DV7PRM FOLLOWS *** END SUBROUTINE DV7SCL(N, X, A, Y) C C *** SET X(I) = A*Y(I), I = 1(1)N *** C INTEGER N DOUBLE PRECISION A, X(N), Y(N) C INTEGER I C DO 10 I = 1, N 10 X(I) = A * Y(I) 999 RETURN C *** LAST LINE OF DV7SCL FOLLOWS *** END SUBROUTINE DV7SCP(P, Y, S) C C *** SET P-VECTOR Y TO SCALAR S *** C INTEGER P DOUBLE PRECISION S, Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = S RETURN END SUBROUTINE DV7SHF(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION *** C INTEGER N, K DOUBLE PRECISION X(N) C INTEGER I, NM1 DOUBLE PRECISION T C IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T 999 RETURN END SUBROUTINE DV7SWP(N, X, Y) C C *** INTERCHANGE N-VECTORS X AND Y. *** C INTEGER N DOUBLE PRECISION X(N), Y(N) C INTEGER I DOUBLE PRECISION T C DO 10 I = 1, N T = X(I) X(I) = Y(I) Y(I) = T 10 CONTINUE 999 RETURN C *** LAST CARD OF DV7SWP FOLLOWS *** END SUBROUTINE DV7VMP(N, X, Y, Z, K) C C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) *** C INTEGER N, K DOUBLE PRECISION X(N), Y(N), Z(N) INTEGER I C IF (K .GE. 0) GO TO 20 DO 10 I = 1, N 10 X(I) = Y(I) / Z(I) GO TO 999 C 20 DO 30 I = 1, N 30 X(I) = Y(I) * Z(I) 999 RETURN C *** LAST CARD OF DV7VMP FOLLOWS *** END SUBROUTINE DW7ZBF (L, N, S, W, Y, Z) C C *** COMPUTE Y AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE. C INTEGER N DOUBLE PRECISION L(1), S(N), W(N), Y(N), Z(N) C DIMENSION L(N*(N+1)/2) C C-------------------------- PARAMETER USAGE -------------------------- C C L (I/O) CHOLESKY FACTOR OF HESSIAN, A LOWER TRIANG. MATRIX STORED C COMPACTLY BY ROWS. C N (INPUT) ORDER OF L AND LENGTH OF S, W, Y, Z. C S (INPUT) THE STEP JUST TAKEN. C W (OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 CORRECTION TO L. C Y (INPUT) CHANGE IN GRADIENTS CORRESPONDING TO S. C Z (OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 CORRECTION TO L. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C WHEN S IS COMPUTED IN CERTAIN WAYS, E.G. BY GQTSTP OR C DBLDOG, IT IS POSSIBLE TO SAVE N**2/2 OPERATIONS SINCE (L**T)*S C OR L*(L**T)*S IS THEN KNOWN. C IF THE BFGS UPDATE TO L*(L**T) WOULD REDUCE ITS DETERMINANT TO C LESS THAN EPS TIMES ITS OLD VALUE, THEN THIS ROUTINE IN EFFECT C REPLACES Y BY THETA*Y + (1 - THETA)*L*(L**T)*S, WHERE THETA C (BETWEEN 0 AND 1) IS CHOSEN TO MAKE THE REDUCTION FACTOR = EPS. C C *** GENERAL *** C C CODED BY DAVID M. GAY (FALL 1979). C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** FUNCTIONS AND SUBROUTINES CALLED *** C DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR, DL7IVM, DL7TVM C DD7TPR RETURNS INNER PRODUCT OF TWO VECTORS. C DL7IVM MULTIPLIES L**-1 TIMES A VECTOR. C DL7TVM MULTIPLIES L**T TIMES A VECTOR. C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I DOUBLE PRECISION CS, CY, EPS, EPSRT, ONE, SHS, YS, THETA C C *** DATA INITIALIZATIONS *** C C/6 C DATA EPS/0.1D+0/, ONE/1.D+0/ C/7 PARAMETER (EPS=0.1D+0, ONE=1.D+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C CALL DL7TVM(N, W, L, S) SHS = DD7TPR(N, W, W) YS = DD7TPR(N, Y, S) IF (YS .GE. EPS*SHS) GO TO 10 THETA = (ONE - EPS) * SHS / (SHS - YS) EPSRT = DSQRT(EPS) CY = THETA / (SHS * EPSRT) CS = (ONE + (THETA-ONE)/EPSRT) / SHS GO TO 20 10 CY = ONE / (DSQRT(YS) * DSQRT(SHS)) CS = ONE / SHS 20 CALL DL7IVM(N, Z, L, Y) DO 30 I = 1, N 30 Z(I) = CY * Z(I) - CS * W(I) C 999 RETURN C *** LAST CARD OF DW7ZBF FOLLOWS *** END SUBROUTINE DXTRAP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST) C C ASSUME AN EXPANSION FOR THE VECTOR VALUED FUNCTION T(H) OF THE FORM C C T(H) = T(0) + SUM(J=1,2,3,...)(A(J)*H**(J*GAMMA)) C C WHERE THE A(J) ARE CONSTANT VECTORS AND GAMMA IS A POSITIVE CONSTANT. C C GIVEN T(H(M)), WHERE H(M)=H0/N(M), M=1,2,3,..., THIS ROUTINE USES C POLYNOMIAL (XPOLY), OR RATIONAL (.NOT.XPOLY), EXTRAPOLATION TO C SEQUENTIALLY APPROXIMATE T(0). C C INPUT C C TM - TM = T(H(M)) FOR THIS CALL. C M - H(M) WAS USED TO OBTAIN TM. C NVAR - THE LENGTH OF THE VECTOR TM. C NG - THE DOUBLE PRECISION VALUES C C NG(I) = N(I)**GAMMA C C FOR I=1,...,M. NG MUST BE A MONOTONE INCREASING ARRAY. C KMAX - THE MAXIMUM NUMBER OF COLUMNS TO BE USED IN THE C EXTRAPOLATION PROCESS. C XPOLY - IF XPOLY=.TRUE., THEN USE POLYNOMIAL EXTRAPOLATION. C IF XPOLY=.FALSE., THEN USE RATIONAL EXTRAPOLATION. C T - THE BOTTOM EDGE OF THE EXTRAPOLATION LOZENGE. C T(I,J) SHOULD CONTAIN THE J-TH EXTRAPOLATE OF THE I-TH C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M-1), C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX). C C WHEN M=1, T MAY CONTAIN ANYTHING. C C FOR M.GT.1, NOTE THAT THE OUTPUT VALUE OF T AT THE C (M-1)-ST CALL IS THE INPUT FOR THE M-TH CALL. C THUS, THE USER NEED NEVER PUT ANYTHING INTO T, C BUT HE CAN NOT ALTER ANY ELEMENT OF T BETWEEN C CALLS TO DXTRAP. C C OUTPUT C C TM - TM(I)=THE MOST ACCURATE APPROXIMATION IN THE LOZENGE C FOR THE I-TH VARIABLE, I=1,...,NVAR. C T - T(I,J) CONTAINS THE J-TH EXTRAPOLATE OF THE I-TH C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M), C FOR I=1,...,NVAR AND J=1,...,MIN(M,KMAX). C ERROR - ERROR(I,J) GIVES THE SIGNED BULIRSCH-STOER ESTIMATE OF THE C ERROR IN THE J-TH EXTRAPOLATE OF THE I-TH COMPONENT OF C T(H) BASED ON THE SEQUENCE H(1),...,H(M-1), C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX). C IF ERROR=EBEST AS ARRAYS, THEN THE ABOVE ELEMENTS C ARE NOT STORED. RATHER, EBEST=ERROR IS LOADED AS DESCRIBED C BELOW. C EBEST - EBEST(I)=THE ABSOLUTE VALUE OF THE ERROR IN TM(I), C I=1,...,NVAR. THIS ARRAY IS FULL OF GARBAGE WHEN M=1. C C SCRATCH SPACE ALLOCATED - MIN(M-1,KMAX) DOUBLE PRECISION WORDS + C C MIN(M-1,KMAX) INTEGER WORDS. C C ERROR STATES - C C 1 - M.LT.1. C 2 - NVAR.LT.1. C 3 - NG(1).LT.1. C 4 - KMAX.LT.1. C 5 - NG IS NOT MONOTONE INCREASING. C DOUBLE PRECISION TM(NVAR),NG(M),T(NVAR,1) C DOUBLE PRECISION T(NVAR,MIN(M,KMAX)) REAL ERROR(NVAR,1),EBEST(NVAR) C REAL ERROR(NVAR,MIN(M-1,KMAX)) LOGICAL XPOLY C LOGICAL ESAVE C COMMON /CSTAK/DS DOUBLE PRECISION DS(500) DOUBLE PRECISION WS(1) REAL RS(1000) EQUIVALENCE (DS(1),WS(1)),(DS(1),RS(1)) C C ... CHECK THE INPUT. C C/6S C IF (M.LT.1) CALL SETERR(15HDXTRAP - M.LT.1,15,1,2) C IF (NVAR.LT.1) CALL SETERR(18HDXTRAP - NVAR.LT.1,18,2,2) C IF (NG(1).LT.1.0D0) CALL SETERR(19HDXTRAP - NG(1).LT.1,19,3,2) C IF (KMAX.LT.1) CALL SETERR(18HDXTRAP - KMAX.LT.1,18,4,2) C/7S IF (M.LT.1) CALL SETERR('DXTRAP - M.LT.1',15,1,2) IF (NVAR.LT.1) CALL SETERR('DXTRAP - NVAR.LT.1',18,2,2) IF (NG(1).LT.1.0D0) CALL SETERR('DXTRAP - NG(1).LT.1',19,3,2) IF (KMAX.LT.1) CALL SETERR('DXTRAP - KMAX.LT.1',18,4,2) C/ C IF (M.EQ.1) GO TO 20 C DO 10 I=2,M C/6S C IF (NG(I-1).GE.NG(I)) CALL SETERR C 1 (38HDXTRAP - NG IS NOT MONOTONE INCREASING,38,5,2) C/7S IF (NG(I-1).GE.NG(I)) CALL SETERR 1 ('DXTRAP - NG IS NOT MONOTONE INCREASING',38,5,2) C/ 10 CONTINUE C C ... SEE IF ERROR=EBEST AS ARRAYS. IF (ESAVE), THEN LOAD ERROR. C 20 ERROR(1,1)=1.0E0 EBEST(1)=2.0E0 ESAVE=ERROR(1,1).NE.EBEST(1) C C ... ALLOCATE SCRATCH SPACE. C IRHG=1 IEMAG=1 IF (M.GT.1) IRHG=ISTKGT(MIN0(M-1,KMAX),4) IF (M.GT.1) IEMAG=ISTKGT(MIN0(M-1,KMAX),3) C CALL D0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,WS(IRHG), 1 RS(IEMAG),ESAVE) C IF (M.GT.1) CALL ISTKRL(2) C RETURN C END DOUBLE PRECISION FUNCTION DZERO(F,A,B,T) C C FINDS THE REAL ROOT OF THE FUNCTION F LYING BETWEEN A AND B C TO WITHIN A TOLERANCE OF C C 6*D1MACH(3) * DABS(DZERO) + 2 * T C C F(A) AND F(B) MUST HAVE OPPOSITE SIGNS C C THIS IS BRENTS ALGORITHM C C A, STORED IN SA, IS THE PREVIOUS BEST APPROXIMATION (I.E. THE OLD B) C B, STORED IN SB, IS THE CURRENT BEST APPROXIMATION C C IS THE MOST RECENTLY COMPUTED POINT SATISFYING F(B)*F(C) .LT. 0 C D CONTAINS THE CORRECTION TO THE APPROXIMATION C E CONTAINS THE PREVIOUS VALUE OF D C M CONTAINS THE BISECTION QUANTITY (C-B)/2 C DOUBLE PRECISION F,A,B,T,TT,SA,SB,C,D,E,FA,FB,FC,TOL,M,P,Q,R,S EXTERNAL F DOUBLE PRECISION D1MACH C TT = T IF (T .LE. 0.0D0) TT = 10.D0*D1MACH(1) C SA = A SB = B FA = F(SA) FB = F(SB) IF (FA .NE. 0.0D0) GO TO 5 DZERO = SA RETURN 5 IF (FB .EQ. 0.0D0) GO TO 140 C/6S C IF (DSIGN(FA,FB) .EQ. FA) CALL SETERR( C 1 47H DZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN, 47, 1, 1) C/7S IF (DSIGN(FA,FB) .EQ. FA) CALL SETERR( 1 ' DZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN', 47, 1, 1) C/ C 10 C = SA FC = FA E = SB-SA D = E C C INTERCHANGE B AND C IF DABS F(C) .LT. DABS F(B) C 20 IF (DABS(FC).GE.DABS(FB)) GO TO 30 SA = SB SB = C C = SA FA = FB FB = FC FC = FA C 30 TOL = 2.0D0*D1MACH(4)*DABS(SB)+TT M = 0.5D0*(C-SB) C C SUCCESS INDICATED BY M REDUCES TO UNDER TOLERANCE OR C BY F(B) = 0 C IF ((DABS(M).LE.TOL).OR.(FB.EQ.0.0D0)) GO TO 140 C C A BISECTION IS FORCED IF E, THE NEXT-TO-LAST CORRECTION C WAS LESS THAN THE TOLERANCE OR IF THE PREVIOUS B GAVE C A SMALLER F(B). OTHERWISE GO TO 40. C IF ((DABS(E).GE.TOL).AND.(DABS(FA).GE.DABS(FB))) GO TO 40 E = M D = E GO TO 100 40 S = FB/FA C C QUADRATIC INTERPOLATION CAN ONLY BE DONE IF A (IN SA) C AND C ARE DIFFERENT POINTS. C OTHERWISE DO THE FOLLOWING LINEAR INTERPOLATION C IF (SA.NE.C) GO TO 50 P = 2.0D0*M*S Q = 1.0D0-S GO TO 60 C C INVERSE QUADRATIC INTERPOLATION C 50 Q = FA/FC R = FB/FC P = S*(2.0D0*M*Q*(Q-R)-(SB-SA)*(R-1.0D0)) Q = (Q-1.0D0)*(R-1.0D0)*(S-1.0D0) 60 IF (P.LE.0.0D0) GO TO 70 Q = -Q GO TO 80 70 P = -P C C UPDATE THE QUANTITIES USING THE NEWLY COMPUTED C INTERPOLATE UNLESS IT WOULD EITHER FORCE THE C NEW POINT TOO FAR TO ONE SIDE OF THE INTERVAL C OR WOULD REPRESENT A CORRECTION GREATER THAN C HALF THE PREVIOUS CORRECTION. C C IN THESE LAST TWO CASES - DO THE BISECTION C BELOW (FROM STATEMENT 90 TO 100) C 80 S = E E = D IF ((2.0D0*P.GE.3.0D0*M*Q-DABS(TOL*Q)).OR. 1 (P.GE.DABS(0.5D0*S*Q))) GO TO 90 D = P/Q GO TO 100 90 E = M D = E C C SET A TO THE PREVIOUS B C 100 SA = SB FA = FB C C IF THE CORRECTION TO BE MADE IS SMALLER THAN C THE TOLERANCE, JUST TAKE A DELTA STEP (DELTA=TOLERANCE) C B = B + DELTA * SIGN(M) C IF (DABS(D).LE.TOL) GO TO 110 SB = SB+D GO TO 130 C 110 IF (M.LE.0.0D0) GO TO 120 SB = SB+TOL GO TO 130 C 120 SB = SB-TOL 130 FB = F(SB) C C IF F(B) AND F(C) HAVE THE SAME SIGN ONLY C LINEAR INTERPOLATION (NOT INVERSE QUADRATIC) C CAN BE DONE C IF ((FB.GT.0.0D0).AND.(FC.GT.0.0D0)) GO TO 10 IF ((FB.LE.0.0D0).AND.(FC.LE.0.0D0)) GO TO 10 GO TO 20 C C***SUCCESS*** 140 DZERO = SB RETURN END SUBROUTINE E9RINT(MESSG,NW,NERR,SAVE) C C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . C C CHANGED, BY P.FOX, MAY 18, 1983, FROM THE ORIGINAL VERSION IN ORDER C TO GET RID OF THE FORTRAN CARRIAGE CONTROL LINE OVERWRITE C CHARACTER +, WHICH HAS ALWAYS CAUSED TROUBLE. C FOR THE RECORD, THE PREVIOUS VERSION HAD THE FOLLOWING ARRAY C AND CALLS - (WHERE CCPLUS WAS DECLARED OF TYPE INTEGER) C C DATA CCPLUS / 1H+ / C C DATA FMT( 1) / 1H( / C DATA FMT( 2) / 1HA / C DATA FMT( 3) / 1H1 / C DATA FMT( 4) / 1H, / C DATA FMT( 5) / 1H1 / C DATA FMT( 6) / 1H4 / C DATA FMT( 7) / 1HX / C DATA FMT( 8) / 1H, / C DATA FMT( 9) / 1H7 / C DATA FMT(10) / 1H2 / C DATA FMT(11) / 1HA / C DATA FMT(12) / 1HX / C DATA FMT(13) / 1HX / C DATA FMT(14) / 1H) / C C CALL S88FMT(2,I1MACH(6),FMT(12)) C WRITE(IWUNIT,FMT) CCPLUS,(MESSGP(I),I=1,NWP) C C/6S C INTEGER MESSG(NW) C/7S CHARACTER*1 MESSG(NW) C/ LOGICAL SAVE C C MESSGP STORES AT LEAST THE FIRST 72 CHARACTERS OF THE PREVIOUS C MESSAGE. ITS LENGTH IS MACHINE DEPENDENT AND MUST BE AT LEAST C C 1 + 71/(THE NUMBER OF CHARACTERS STORED PER INTEGER WORD). C C/6S C INTEGER MESSGP(36),FMT(10), FMT10(10) C EQUIVALENCE (FMT(1),FMT10(1)) C/7S CHARACTER*1 MESSGP(72),FMT(10) CHARACTER*10 FMT10 EQUIVALENCE (FMT(1),FMT10) C/ C C START WITH NO PREVIOUS MESSAGE. C C/6S C DATA MESSGP(1)/1H1/, NWP/0/, NERRP/0/ C/7S DATA MESSGP(1)/'1'/, NWP/0/, NERRP/0/ C/ C C SET UP THE FORMAT FOR PRINTING THE ERROR MESSAGE. C THE FORMAT IS SIMPLY (A1,14X,72AXX) WHERE XX=I1MACH(6) IS THE C NUMBER OF CHARACTERS STORED PER INTEGER WORD. C C/6S C DATA FMT( 1) / 1H( / C DATA FMT( 2) / 1H3 / C DATA FMT( 3) / 1HX / C DATA FMT( 4) / 1H, / C DATA FMT( 5) / 1H7 / C DATA FMT( 6) / 1H2 / C DATA FMT( 7) / 1HA / C DATA FMT( 8) / 1HX / C DATA FMT( 9) / 1HX / C DATA FMT(10) / 1H) / C/7S DATA FMT( 1) / '(' / DATA FMT( 2) / '3' / DATA FMT( 3) / 'X' / DATA FMT( 4) / ',' / DATA FMT( 5) / '7' / DATA FMT( 6) / '2' / DATA FMT( 7) / 'A' / DATA FMT( 8) / 'X' / DATA FMT( 9) / 'X' / DATA FMT(10) / ')' / C/ C IF (.NOT.SAVE) GO TO 20 C C SAVE THE MESSAGE. C NWP=NW NERRP=NERR DO 10 I=1,NW 10 MESSGP(I)=MESSG(I) C GO TO 30 C 20 IF (I8SAVE(1,0,.FALSE.).EQ.0) GO TO 30 C C PRINT THE MESSAGE. C IWUNIT=I1MACH(4) WRITE(IWUNIT,9000) NERRP 9000 FORMAT(7H ERROR ,I4,4H IN ) C C/6S C CALL S88FMT(2,I1MACH(6),FMT( 8)) C/7S CALL S88FMT(2, 1, FMT(8)) C/ WRITE(IWUNIT,FMT10) (MESSGP(I),I=1,NWP) C 30 RETURN C END SUBROUTINE EIGEN(NM,N,A,WR,WI,Z) COMMON/CSTAK/DSTAK(500) C REAL A(NM,N),WR(N),WI(N),Z(NM,N) REAL RSTAK(1000) C EQUIVALENCE (DSTAK(1),RSTAK(1)) C C EIGEN FINDS THE EIGENVALUES AND EIGENVECTORS C OF A REAL MATRIX (NOT IMAGINARY) BY C CALLING THE SEQUENCE OF SUBROUTINES C ORTHE,ORTRA, AND HQR2, WHICH, IN TURN, ARE C THE EISPACK ROUTINES ORTHES, ORTRAN, AND HQR2, C ADJUSTED FOR USE IN THE PORT LIBRARY. C C ON INPUT - C C NM - AN INTEGER INPUT VARIABLE SET EQUAL TO C THE ROW DIMENSION OF THE TWO-DIMENSIONAL ARRAYS C A AND Z AS SPECIFIED IN THE DIMENSION STATEMENTS C FOR A AND Z IN THE CALLING PROGRAM. C C N - AN INTEGER INPUT VARIABLE SET EQUAL TO THE C ORDER OF THE MATRIX A. C C N MUST NOT BE GREATER THAN NM. C C A - THE MATRIX, A REAL TWO-DIMENSIONAL C ARRAY WITH ROW DIMENSION NM AND COLUMN C DIMENSION AT LEAST N. C C A IS OVERWRITTEN. C C C C ON OUTPUT - C C WR - A REAL ARRAY OF DIMENSION C AT LEAST N CONTAINING THE REAL PARTS OF THE EIGENVALUES C C WI - A REAL ARRAY OF DIMENSION C AT LEAST N CONTAINING THE IMAGINARY PARTS OF THE EIGENVALUES. C C THE EIGENVALUES ARE UNORDERED EXCEPT THAT C COMPLEX CONJUGATE PAIRS OF EIGENVALUES C APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING C THE POSITIVE IMAGINARY PART FIRST. C C Z - A REAL TWO-DIMENSIONAL ARRAY C WITH ROW DIMENSION NM AND COLUMN DIMENSION C AT LEAST N CONTAINING THE REAL AND IMAGINARY PARTS C OF THE EIGENVECTORS. C C IF THE J-TH EIGENVALUE IS REAL, THE J-TH C COLUMN OF Z CONTAINS ITS EIGENVECTOR. C C IF THE J-TH EIGENVALUE IS COMPLEX WITH C POSITIVE REAL PART, THE J-TH AND (J+1)-TH C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY C PARTS OF ITS EIGENVECTOR. C C THE CONJUGATE OF THIS VECTOR IS THE C EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. C THE EIGENVECTORS ARE NOT NORMALIZED. C C C ERROR STATES - C C 1 - N IS GREATER THAN NM C C K - THE K-TH EIGENVALUE COULD NOT BE COMPUTED C WITHIN 30 ITERATIONS. C C THE EIGENVALUES IN THE WR AND WRI ARRAYS C SHOULD BE CORRECT FOR INDICES C K+1, K+2,...,N, BUT NO EIGENVECTORS ARE COMPUTED. C C C C C CHECK FOR INPUT ERROR IN N C C/6S C IF (N .GT. NM) CALL SETERR( C 1 29H EIGEN - N IS GREATER THAN NM,29,1,2) C/7S IF (N .GT. NM) CALL SETERR( 1 ' EIGEN - N IS GREATER THAN NM',29,1,2) C/ C C ALLOCATE A SCRATCH VECTOR IORT = ISTKGT(N,3) C CALL ORTHE (NM,N,1,N,A,RSTAK(IORT)) CALL ORTRA (NM,N,1,N,A,RSTAK(IORT),Z) CALL HQR2 (NM,N,1,N,A,WR,WI,Z,IERR) C IF (IERR .NE. 0) GO TO 10 CALL ISTKRL(1) RETURN C/6S C 10 CALL SETERR( C 1 34H EIGEN - FAILED ON THAT EIGENVALUE,34,IERR,1) C/7S 10 CALL SETERR( 1 ' EIGEN - FAILED ON THAT EIGENVALUE',34,IERR,1) C/ C CALL ISTKRL(1) RETURN END SUBROUTINE ENTER(IRNEW) C C THIS ROUTINE SAVES C C 1) THE CURRENT NUMBER OF OUTSTANDING STORAGE ALLOCATIONS, LOUT, AND C 2) THE CURRENT RECOVERY LEVEL, LRECOV, C C IN AN ENTER-BLOCK IN THE STACK. C C IT ALSO SETS LRECOV = IRNEW IF IRNEW = 1 OR 2. C IF IRNEW = 0, THEN THE RECOVERY LEVEL IS NOT ALTERED. C C SCRATCH SPACE ALLOCATED - 3 INTEGER WORDS ARE LEFT ON THE STACK. C C ERROR STATES - C C 1 - MUST HAVE IRNEW = 0, 1 OR 2. C COMMON /CSTAK/DSTACK DOUBLE PRECISION DSTACK(500) INTEGER ISTACK(1000) EQUIVALENCE (DSTACK(1),ISTACK(1)) EQUIVALENCE (ISTACK(1),LOUT) C C/6S C IF (0.GT.IRNEW .OR. IRNEW.GT.2) C 1 CALL SETERR(35HENTER - MUST HAVE IRNEW = 0, 1 OR 2,35,1,2) C/7S IF (0.GT.IRNEW .OR. IRNEW.GT.2) 1 CALL SETERR('ENTER - MUST HAVE IRNEW = 0, 1 OR 2',35,1,2) C/ C C ALLOCATE SPACE FOR SAVING THE ABOVE 2 ITEMS C AND A BACK-POINTER FOR CHAINING THE ENTER-BLOCKS TOGETHER. C INOW=ISTKGT(3,2) C C SAVE THE CURRENT NUMBER OF OUTSTANDING ALLOCATIONS. C ISTACK(INOW)=LOUT C C SAVE THE CURRENT RECOVERY LEVEL. C CALL ENTSRC(ISTACK(INOW+1),IRNEW) C C SAVE A BACK-POINTER TO THE START OF THE PREVIOUS ENTER-BLOCK. C ISTACK(INOW+2)=I8TSEL(INOW) C RETURN C END SUBROUTINE ENTSRC(IROLD,IRNEW) C C THIS ROUTINE RETURNS IROLD = LRECOV AND SETS LRECOV = IRNEW. C C IF THERE IS AN ACTIVE ERROR STATE, THE MESSAGE IS PRINTED C AND EXECUTION STOPS. C C IRNEW = 0 LEAVES LRECOV UNCHANGED, WHILE C IRNEW = 1 GIVES RECOVERY AND C IRNEW = 2 TURNS RECOVERY OFF. C C ERROR STATES - C C 1 - ILLEGAL VALUE OF IRNEW. C 2 - CALLED WHILE IN AN ERROR STATE. C C/6S C IF (IRNEW.LT.0 .OR. IRNEW.GT.2) C 1 CALL SETERR(31HENTSRC - ILLEGAL VALUE OF IRNEW,31,1,2) C/7S IF (IRNEW.LT.0 .OR. IRNEW.GT.2) 1 CALL SETERR('ENTSRC - ILLEGAL VALUE OF IRNEW',31,1,2) C/ C IROLD=I8SAVE(2,IRNEW,IRNEW.NE.0) C C IF HAVE AN ERROR STATE, STOP EXECUTION. C C/6S C IF (I8SAVE(1,0,.FALSE.) .NE. 0) CALL SETERR C 1 (39HENTSRC - CALLED WHILE IN AN ERROR STATE,39,2,2) C/7S IF (I8SAVE(1,0,.FALSE.) .NE. 0) CALL SETERR 1 ('ENTSRC - CALLED WHILE IN AN ERROR STATE',39,2,2) C/ C RETURN C END SUBROUTINE EPRINT C C THIS SUBROUTINE PRINTS THE LAST ERROR MESSAGE, IF ANY. C C/6S C INTEGER MESSG(1) C/7S CHARACTER*1 MESSG(1) C/ C CALL E9RINT(MESSG,1,1,.FALSE.) RETURN C END SUBROUTINE ERROFF C C TURNS OFF THE ERROR STATE OFF BY SETTING LERROR=0. C I=I8SAVE(1,0,.TRUE.) RETURN C END SUBROUTINE F7DHB(B, D, G, IRT, IV, LIV, LV, P, V, X) C C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING C *** AT V(IV(FDH)) = V(-IV(H)). HONOR SIMPLE BOUNDS IN B. C C *** IF IV(COVREQ) .GE. 0 THEN F7DHB USES GRADIENT DIFFERENCES, C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN G7LIT. C C IRT VALUES... C 1 = COMPUTE FUNCTION VALUE, I.E., V(F). C 2 = COMPUTE G. C 3 = DONE. C C C *** PARAMETER DECLARATIONS *** C INTEGER IRT, LIV, LV, P INTEGER IV(LIV) REAL B(2,P), D(P), G(P), V(LV), X(P) C C *** LOCAL VARIABLES *** C LOGICAL OFFSID INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2, 1 NEWM1, PP1O2, STPI, STPM, STP0 REAL DEL, DEL0, T, XM, XM1 REAL HALF, HLIM, ONE, TWO, ZERO C C *** EXTERNAL SUBROUTINES *** C EXTERNAL V7CPY, V7SCP C C V7CPY.... COPY ONE VECTOR TO ANOTHER. C V7SCP... COPY SCALAR TO ALL COMPONENTS OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE, 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE C C/6 C DATA HALF/0.5E+0/, HLIM/0.1E+0/, ONE/1.E+0/, TWO/2.E+0/, C 1 ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, HLIM=0.1E+0, ONE=1.E+0, TWO=2.E+0, 1 ZERO=0.E+0) C/ C C/6 C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/, C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/, C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/ C/7 PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10, 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7, 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IRT = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 HES = IABS(IV(H)) IV(H) = -HES IV(FDH) = 0 IV(KAGQT) = -1 V(FX) = V(F) C *** SUPPLY ZEROS IN CASE B(1,I) = B(2,I) FOR SOME I *** CALL V7SCP(P*(P+1)/2, V(HES), ZERO) 10 IF (M .GT. P) GO TO 999 IF (KIND .LT. 0) GO TO 120 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P IF (M .GT. 0) GO TO 20 C *** FIRST CALL ON F7DHB. SET GSAVE = G, TAKE FIRST STEP *** CALL V7CPY(P, V(GSAVE1), G) IV(SWITCH) = IV(NFGCAL) GO TO 80 C 20 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 30 C C *** HANDLE OVERSIZE V(DELTA) *** C DEL0 = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M))) DEL = HALF * DEL IF ( ABS(DEL/DEL0) .LE. HLIM) GO TO 140 C 30 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DEL = ONE / DEL DO 40 I = 1, P G(I) = DEL * (G(I) - V(GSAVE1)) GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 50 I = 1, MM1 IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I)) K = K + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P IF (B(1,I) .LT. B(2,I)) V(L) = G(I) L = L + I 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 340 IF (B(1,M) .GE. B(2,M)) GO TO 80 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M))) XM = X(M) IF (XM .LT. ZERO) GO TO 90 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 GO TO 280 90 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 GO TO 280 C 100 DEL = -DEL 110 V(XMSAVE) = XM X(M) = XM1 V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 120 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 HES = -IV(H) IF (M .GT. 0) GO TO 130 C *** FIRST CALL ON F7DHB. *** IV(SAVEI) = 0 GO TO 240 C 130 IF (IV(TOOBIG) .EQ. 0) GO TO 150 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** 140 IV(FDH) = -2 GO TO 350 150 I = IV(SAVEI) IF (I .GT. 0) GO TO 190 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C PP1O2 = P * (P-1) / 2 HPM = HES + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C NEWM1 = 1 GO TO 260 160 HMI = HES + MM1O2 IF (MM1 .EQ. 0) GO TO 180 HPI = HES + PP1O2 DO 170 I = 1, MM1 T = ZERO IF (B(1,I) .LT. B(2,I)) T = V(FX) - (V(F) + V(HPI)) V(HMI) = T HMI = HMI + 1 HPI = HPI + 1 170 CONTINUE 180 V(HMI) = V(F) - TWO*V(FX) IF (OFFSID) V(HMI) = V(FX) - TWO*V(F) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 0 GO TO 200 C 190 X(I) = V(DELTA) C C *** FINISH COMPUTING H(M,I) *** C STPI = STP0 + I HMI = HES + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) 200 I = I + 1 IF (I .GT. M) GO TO 230 IF (B(1,I) .LT. B(2,I)) GO TO 210 GO TO 200 C 210 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IRT = 1 IF (I .LT. M) GO TO 999 NEWM1 = 2 GO TO 260 220 X(M) = V(XMSAVE) - DEL IF (OFFSID) X(M) = V(XMSAVE) + TWO*DEL GO TO 999 C 230 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 240 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 330 IF (B(1,M) .LT. B(2,M)) GO TO 250 GO TO 240 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C 250 V(XMSAVE) = X(M) NEWM1 = 3 260 XM = V(XMSAVE) DEL = V(DLTFDC) * AMAX1(ONE/D(M), ABS(XM)) XM1 = XM + DEL OFFSID = .FALSE. IF (XM1 .LE. B(2,M)) GO TO 270 OFFSID = .TRUE. XM1 = XM - DEL IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300 GO TO 280 270 IF (XM-DEL .GE. B(1,M)) GO TO 290 OFFSID = .TRUE. IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310 C 280 IV(FDH) = -2 GO TO 350 C 290 IF (XM .GE. ZERO) GO TO 310 XM1 = XM - DEL 300 DEL = -DEL 310 GO TO (160, 220, 320), NEWM1 320 X(M) = XM1 STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES C *** FROM LAST ROW OF FDH... C 330 IF (B(1,P) .LT. B(2,P)) GO TO 340 I = HES + P*(P-1)/2 CALL V7SCP(P, V(I), ZERO) C C *** RESTORE V(F), ETC. *** C 340 IV(FDH) = HES 350 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL V7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST LINE OF F7DHB FOLLOWS *** END SUBROUTINE F7HES(D, G, IRT, IV, LIV, LV, P, V, X) C C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING C *** AT V(IV(FDH)) = V(-IV(H)). C C *** IF IV(COVREQ) .GE. 0 THEN F7HES USES GRADIENT DIFFERENCES, C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN G7LIT. C C IRT VALUES... C 1 = COMPUTE FUNCTION VALUE, I.E., V(F). C 2 = COMPUTE G. C 3 = DONE. C C C *** PARAMETER DECLARATIONS *** C INTEGER IRT, LIV, LV, P INTEGER IV(LIV) REAL D(P), G(P), V(LV), X(P) C C *** LOCAL VARIABLES *** C INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2, 1 PP1O2, STPI, STPM, STP0 REAL DEL, HALF, NEGPT5, ONE, TWO, ZERO C C *** EXTERNAL SUBROUTINES *** C EXTERNAL V7CPY C C V7CPY.... COPY ONE VECTOR TO ANOTHER. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE, 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE C C/6 C DATA HALF/0.5E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, C 1 ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, NEGPT5=-0.5E+0, ONE=1.E+0, TWO=2.E+0, 1 ZERO=0.E+0) C/ C C/6 C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/, C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/, C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/ C/7 PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10, 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7, 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IRT = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 IV(H) = -IABS(IV(H)) IV(FDH) = 0 IV(KAGQT) = -1 V(FX) = V(F) 10 IF (M .GT. P) GO TO 999 IF (KIND .LT. 0) GO TO 110 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P IF (M .GT. 0) GO TO 20 C *** FIRST CALL ON F7HES. SET GSAVE = G, TAKE FIRST STEP *** CALL V7CPY(P, V(GSAVE1), G) IV(SWITCH) = IV(NFGCAL) GO TO 90 C 20 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 40 C C *** HANDLE OVERSIZE V(DELTA) *** C IF (DEL*X(M) .GT. ZERO) GO TO 30 C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT *** IV(FDH) = -2 GO TO 220 C C *** TRY SHRINKING V(DELTA) *** 30 DEL = NEGPT5 * DEL GO TO 100 C 40 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DO 50 I = 1, P G(I) = (G(I) - V(GSAVE1)) / DEL GSAVE1 = GSAVE1 + 1 50 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 70 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 60 I = 1, MM1 V(K) = HALF * (V(K) + G(I)) K = K + 1 60 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 70 L = L + 1 DO 80 I = M, P V(L) = G(I) L = L + I 80 CONTINUE C 90 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 210 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 100 X(M) = X(M) + DEL V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 110 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 120 C *** FIRST CALL ON F7HES. *** IV(SAVEI) = 0 GO TO 200 C 120 I = IV(SAVEI) HES = -IV(H) IF (I .GT. 0) GO TO 180 IF (IV(TOOBIG) .EQ. 0) GO TO 140 C C *** HANDLE OVERSIZE STEP *** C STPM = STP0 + M DEL = V(STPM) IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 130 C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT *** IV(FDH) = -2 GO TO 220 C C *** TRY SHRINKING THE STEP *** 130 DEL = NEGPT5 * DEL X(M) = X(XMSAVE) + DEL V(STPM) = DEL IRT = 1 GO TO 999 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C 140 PP1O2 = P * (P-1) / 2 HPM = HES + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C HMI = HES + MM1O2 IF (MM1 .EQ. 0) GO TO 160 HPI = HES + PP1O2 DO 150 I = 1, MM1 V(HMI) = V(FX) - (V(F) + V(HPI)) HMI = HMI + 1 HPI = HPI + 1 150 CONTINUE 160 V(HMI) = V(F) - TWO*V(FX) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 1 C 170 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI) IRT = 1 GO TO 999 C 180 X(I) = V(DELTA) IF (IV(TOOBIG) .EQ. 0) GO TO 190 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** IV(FDH) = -2 GO TO 220 C C *** FINISH COMPUTING H(M,I) *** C 190 STPI = STP0 + I HMI = HES + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) I = I + 1 IF (I .LE. M) GO TO 170 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 200 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 210 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C DEL = V(DLTFDC) * AMAX1(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** RESTORE V(F), ETC. *** C 210 IV(FDH) = HES 220 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL V7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST CARD OF F7HES FOLLOWS *** END SUBROUTINE FDUMP C THIS IS A DUMMY ROUTINE TO BE SENT OUT ON C THE PORT SEDIT TAPE C RETURN END SUBROUTINE FRMATD(WWIDTH, EWIDTH) C C THIS SUBROUTINE COMPUTES, FOR THE FORMAT SPECIFICATION, DW.E, THE C NUMBER OF DIGITS TO THE RIGHT OF THE DECIMAL POINT, E=EWIDTH, AND C THE FIELD WIDTH, W=WWIDTH. C C WWIDTH INCLUDES THE FIVE POSITIONS NEEDED FOR THE SIGN OF THE C MANTISSA, THE SIGN OF THE EXPONENT, THE 0, THE DECIMAL POINT AND THE C CHARACTER IN THE OUTPUT - +0.XXXXXXXXXD+YYYY C C THE FOLLOWING MACHINE-DEPENDENT VALUES ARE USED - C C I1MACH(10) - THE BASE, B C I1MACH(14) - THE NUMBER OF BASE-B DIGITS IN THE MANTISSA C I1MACH(15) - THE SMALLEST EXPONENT, EMIN C I1MACH(16) - THE LARGEST EXPONENT, EMAX C INTEGER I1MACH, ICEIL, IFLR, EWIDTH, WWIDTH INTEGER DEMIN, DEMAX, EXPWID REAL BASE C BASE = I1MACH(10) C EWIDTH = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(14)) ) C DEMIN = IFLR( ALOG10(BASE)*FLOAT(I1MACH(15)-1) ) + 1 DEMAX = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(16)) ) EXPWID = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1 WWIDTH = EWIDTH + EXPWID + 5 C RETURN END SUBROUTINE FRMATI(IWIDTH) C C THIS SUBROUTINE COMPUTES THE WIDTH, W=IWIDTH, IN THE FORMAT C SPECIFICATION FOR INTEGER VARIABLES. C C FRMATI SETS IWIDTH TO THE NUMBER OF CHARACTER POSITIONS NEEDED C FOR WRITING OUT THE LARGEST INTEGER PLUS ONE POSITION FOR THE SIGN. C C I1MACH(7) IS THE BASE, A, FOR INTEGER REPRESENTATION IN THE MACHINE. C I1MACH(8) IS THE (MAXIMUM) NUMBER OF BASE A DIGITS. C INTEGER I1MACH, ICEIL, IWIDTH C IWIDTH = ICEIL( ALOG10(FLOAT(I1MACH(7)))*FLOAT(I1MACH(8)) ) + 1 C RETURN END SUBROUTINE FRMATR(WWIDTH, EWIDTH) C C THIS SUBROUTINE COMPUTES, FOR THE FORMAT SPECIFICATION, EW.E, THE C NUMBER OF DIGITS TO THE RIGHT OF THE DECIMAL POINT, E=EWIDTH, AND C THE FIELD WIDTH, W=WWIDTH. C C WWIDTH INCLUDES THE FIVE POSITIONS NEEDED FOR THE SIGN OF THE C MANTISSA, THE SIGN OF THE EXPONENT, THE 0, THE DECIMAL POINT AND THE C CHARACTER IN THE OUTPUT - +0.XXXXXXXXXE+YYYY C C THE FOLLOWING MACHINE-DEPENDENT VALUES ARE USED - C C I1MACH(10) - THE BASE, B C I1MACH(11) - THE NUMBER OF BASE-B DIGITS IN THE MANTISSA C I1MACH(12) - THE SMALLEST EXPONENT, EMIN C I1MACH(13) - THE LARGEST EXPONENT, EMAX C INTEGER I1MACH, ICEIL, IFLR, EWIDTH, WWIDTH INTEGER DEMIN, DEMAX, EXPWID REAL BASE C BASE = I1MACH(10) C EWIDTH = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(11)) ) C DEMIN = IFLR( ALOG10(BASE)*FLOAT(I1MACH(12)-1) ) + 1 DEMAX = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(13)) ) EXPWID = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1 WWIDTH = EWIDTH + EXPWID + 5 C RETURN END SUBROUTINE G7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) REAL B(2,P), D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X. C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 80. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C G7ITB IS SIMILAR TO G7LIT, EXCEPT FOR THE EXTRA PARAMETER B C -- G7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C G7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS), AND G7ITB BUILDS AN APPROXIMATION, S, TO THE C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE, C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S. C G7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO USE S WHEN CHOOSING C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL). C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S, G7ITB ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING G7ITB WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO N2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT N2GB USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH N2GB (AND NL2SOL), IV(1) C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE C EXPLAINED BELOW, AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM C N2GB (AND N2FB), ARE NOT REFERENCED BY G7ITB OR THE C SUBROUTINES IT CALLS. C C WHEN G7ITB IS FIRST CALLED, I.E., WHEN G7ITB IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES, G7ITB RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE G7ITB WILL MAKE C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL G7ITB AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE G7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME G7ITB RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL G7ITB AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(NFGCAL) TO 0, IN WHICH CASE G7ITB WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL HAVQTR, HAVRM INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1, 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2, 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2, 3 TG1, W1, WLM1, X01 REAL E, GI, STTSST, T, T1, XI C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, RLDST, V2NRM EXTERNAL A7SST, D7TPR, F7DHB, G7QSB,I7COPY, I7PNVR, I7SHFT, 1 ITSUM, L7MSB, L7SQR, L7TVM, L7VML, PARCK, Q7RSH, 2 RLDST, S7DMP, S7IPR, S7LUP, S7LVM, STOPX, V2NRM, 3 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP C C A7SST.... ASSESSES CANDIDATE STEP. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C F7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX). C G7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER. C I7PNVR... INVERTS PERMUTATION ARRAY. C I7SHFT... SHIFTS AN INTEGER VECTOR. C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C L7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C L7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C L7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C PARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C Q7RSH... SHIFTS A QR FACTORIZATION. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C S7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX. C S7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX. C S7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C S7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7IPR... APPLIES A PERMUTATION TO A VECTOR. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT, 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV, 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0, 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS, 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP, 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5, 8 VNEED, VSAVE, W, WSCALE, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.) C C/6 C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/, C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, IVNEED/3/, C 2 KAGQT/33/, KALM/34/, LMAT/42/, MODE/35/, MODEL/5/, C 3 MXFCAL/17/, MXITER/18/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, C 4 NFGCAL/7/, NFCOV/52/, NGCOV/53/, NGCALL/30/, NITER/31/, C 5 P0/48/, PC/41/, PERM/58/, QTR/77/, RADINC/8/, RDREQ/57/, C 6 REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/, STGLIM/11/, C 7 SUSED/64/, SWITCH/12/, TOOBIG/2/, VNEED/4/, VSAVE/60/, W/65/, C 8 XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56, 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, IVNEED=3, 2 KAGQT=33, KALM=34, LMAT=42, MODE=35, MODEL=5, 3 MXFCAL=17, MXITER=18, NEXTIV=46, NEXTV=47, NFCALL=6, 4 NFGCAL=7, NFCOV=52, NGCOV=53, NGCALL=30, NITER=31, 5 P0=48, PC=41, PERM=58, QTR=77, RADINC=8, RDREQ=57, 6 REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, STGLIM=11, 7 SUSED=64, SWITCH=12, TOOBIG=2, VNEED=4, VSAVE=60, W=65, 8 XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/, C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/, C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RELDX/17/, SIZE/55/, STPPAR/5/, TUNER4/29/, C 4 TUNER5/30/, WSCALE/56/ C/7 PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45, 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36, 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RELDX=17, SIZE=55, STPPAR=5, TUNER4=29, 4 TUNER5=30, WSCALE=56) C/ C C C/6 C DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, C 1 ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, 1 ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 C IF (I .LT. 12) GO TO 10 IF (I .GT. 13) GO TO 10 IV(VNEED) = IV(VNEED) + P*(3*P + 25)/2 + 7 IV(IVNEED) = IV(IVNEED) + 4*P 10 CALL PARCK(1, D, IV, LIV, LV, P, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I C C *** STORAGE ALLOCATION *** C 20 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + 2*P IV(DIG) = IV(STEP) + 3*P IV(W) = IV(DIG) + 2*P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IV(IPIVOT) = IV(PERM) + 3*P IV(NEXTIV) = IV(IPIVOT) + P IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(PC) = P V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(IPIVOT) DO 40 I = 1, P IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 680 40 CONTINUE C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IV(1) = 1 IF (IV(S) .LT. 0) GO TO 710 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL V7SCP(P*(P+1)/2, V(S1), ZERO) GO TO 710 C C *** NEW FUNCTION VALUE *** C 50 IF (IV(MODE) .EQ. 0) GO TO 360 IF (IV(MODE) .GT. 0) GO TO 590 C IF (IV(TOOBIG) .EQ. 0) GO TO 690 IV(1) = 63 GO TO 999 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 999 C C *** NEW GRADIENT *** C 70 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 590 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670 C C *** CHOOSE INITIAL PERMUTATION *** C IPI = IV(IPIVOT) IPN = IPI + P - 1 IPIV2 = IV(PERM) - 1 K = IV(PC) P1 = P PP1 = P + 1 RMAT1 = IV(RMAT) HAVRM = RMAT1 .GT. 0 QTR1 = IV(QTR) HAVQTR = QTR1 .GT. 0 C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) *** W1 = IV(W) IF (.NOT. HAVQTR) QTR1 = W1 + P C DO 100 I = 1, P I1 = IV(IPN) IPN = IPN - 1 IF (B(1,I1) .GE. B(2,I1)) GO TO 80 XI = X(I1) GI = G(I1) IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80 IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80 C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED *** J = IPIV2 + I1 IF (IV(J) .GT. K) IV(CNVCOD) = 0 GO TO 100 80 IF (I1 .GE. P1) GO TO 90 I1 = PP1 - I CALL I7SHFT(P1, I1, IV(IPI)) IF (HAVRM) 1 CALL Q7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1)) 90 P1 = P1 - 1 100 CONTINUE IV(PC) = P1 C C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) *** C V(DGNORM) = ZERO IF (P1 .LE. 0) GO TO 110 DIG1 = IV(DIG) CALL V7VMP(P, V(DIG1), G, D, -1) CALL V7IPR(P, IV(IPI), V(DIG1)) V(DGNORM) = V2NRM(P1, V(DIG1)) 110 IF (IV(CNVCOD) .NE. 0) GO TO 580 IF (IV(MODE) .EQ. 0) GO TO 510 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 170 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 600 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 120 H1 = IV(FDH) IF (H1 .LE. 0) GO TO 660 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 130 CALL V2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 140 130 RMAT1 = IV(RMAT) LMAT1 = IV(LMAT) CALL L7SQR(P, V(LMAT1), V(RMAT1)) IPI = IV(IPIVOT) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPI)) CALL S7IPR(P, IV(IPIV1), V(LMAT1)) CALL V2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1)) C C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS *** C 140 DO 160 I = 1, P IF (B(1,I) .LT. B(2,I)) GO TO 160 K = S1 + I*(I-1)/2 CALL V7SCP(I, V(K), ZERO) IF (I .GE. P) GO TO 170 K = K + 2*I - 1 I1 = I + 1 DO 150 J = I1, P V(K) = ZERO K = K + J 150 CONTINUE 160 CONTINUE C 170 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 180 CALL ITSUM(D, G, IV, LIV, LV, P, V, X) 190 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 200 IV(1) = 10 GO TO 999 200 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 220 STEP1 = IV(STEP) DO 210 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 210 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * V2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 220 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL V7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 230 IF (.NOT. STOPX(DUMMY)) GO TO 250 IV(1) = 11 GO TO 260 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 240 IF (V(F) .GE. V(F0)) GO TO 250 V(RADFAC) = ONE K = IV(NITER) GO TO 200 C 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270 IV(1) = 9 260 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 500 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 270 STEP1 = IV(STEP) TG1 = IV(DIG) TD1 = TG1 + P X01 = IV(X0) W1 = IV(W) H1 = IV(H) P1 = IV(PC) IPI = IV(PERM) IPIV1 = IPI + P IPIV2 = IPIV1 + P IPIV0 = IV(IPIVOT) IF (IV(MODEL) .EQ. 2) GO TO 280 C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 280 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 280 LMAT1 = IV(LMAT) WLM1 = W1 + P CALL L7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1), 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0), 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1), 3 V(TG1), V, V(W1), V(WLM1), X, V(X01)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION G7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 330 C 280 IF (H1 .GT. 0) GO TO 320 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C P1LEN = P1*(P1+1)/2 H1 = -H1 IV(H) = H1 IV(FDH) = 0 IF (P1 .LE. 0) GO TO 320 C *** MAKE TEMPORARY PERMUTATION ARRAY *** CALL I7COPY(P, IV(IPI), IV(IPIV0)) J = IV(HC) IF (J .GT. 0) GO TO 290 J = H1 RMAT1 = IV(RMAT) CALL L7SQR(P1, V(H1), V(RMAT1)) GO TO 300 290 CALL V7CPY(P*(P+1)/2, V(H1), V(J)) CALL S7IPR(P, IV(IPI), V(H1)) 300 IF (IV(MODEL) .EQ. 1) GO TO 310 LMAT1 = IV(LMAT) S1 = IV(S) CALL V7CPY(P*(P+1)/2, V(LMAT1), V(S1)) CALL S7IPR(P, IV(IPI), V(LMAT1)) CALL V2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1)) 310 CALL V7CPY(P, V(TD1), D) CALL V7IPR(P, IV(IPI), V(TD1)) CALL S7DMP(P1, V(H1), V(H1), V(TD1), -1) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 320 LMAT1 = IV(LMAT) CALL G7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2), 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1), 2 V(TD1), V(TG1), V, V(W1), X, V(X01)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 330 IF (IV(IRC) .NE. 6) GO TO 340 IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 2 GO TO 370 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 340 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 360 IF (IV(IRC) .NE. 5) GO TO 350 IF (V(RADFAC) .LE. ONE) GO TO 350 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350 STEP1 = IV(STEP) X01 = IV(X0) CALL V2AXY(P, V(STEP1), NEGONE, V(X01), X) IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 0 GO TO 370 C C *** COMPUTE F(X0 + STEP) *** C 350 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 360 RSTRST = 3 370 X01 = IV(X0) V(RELDX) = RLDST(P, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = X01 + P I = IV(RESTOR) + 1 GO TO (410, 380, 390, 400), I 380 CALL V7CPY(P, X, V(X01)) GO TO 410 390 CALL V7CPY(P, V(LSTGST), V(STEP1)) GO TO 410 400 CALL V7CPY(P, V(STEP1), V(LSTGST)) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = RLDST(P, D, X, V(X01)) IV(RESTOR) = RSTRST C C *** IF NECESSARY, SWITCH MODELS *** C 410 IF (IV(SWITCH) .EQ. 0) GO TO 420 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V, V(L)) 420 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL S7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * D7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 430 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 470 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V(L), V) GO TO 230 C 430 IF (-3 .LT. L) GO TO 470 C C *** RECOMPUTE STEP WITH DIFFERENT RADIUS *** C 440 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 230 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST C 450 V(RADIUS) = V(LMAXS) GO TO 270 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 460 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 580 IF (IV(XIRC) .EQ. 14) GO TO 580 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 470 IV(COVMAT) = 0 IV(REGD) = 0 C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C IF (IV(IRC) .NE. 3) GO TO 500 STEP1 = IV(STEP) TEMP1 = STEP1 + P TEMP2 = IV(X0) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL S7LVM(P, V(TEMP1), V(HC1), V(STEP1)) GO TO 490 480 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL V7CPY(P, V(TEMP1), V(STEP1)) CALL V7IPR(P, IV(IPIV0), V(TEMP1)) CALL L7TVM(P, V(TEMP1), V(RMAT1), V(TEMP1)) CALL L7VML(P, V(TEMP1), V(RMAT1), V(TEMP1)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL V7IPR(P, IV(IPIV1), V(TEMP1)) C 490 IF (STPMOD .EQ. 1) GO TO 500 S1 = IV(S) CALL S7LVM(PS, V(TEMP2), V(S1), V(STEP1)) CALL V2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1)) C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 500 IV(NGCALL) = IV(NGCALL) + 1 G01 = IV(W) CALL V7CPY(P, V(G01), G) GO TO 690 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 510 G01 = IV(W) CALL V2AXY(P, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = STEP1 + P TEMP2 = IV(X0) IF (IV(IRC) .NE. 3) GO TO 540 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 520 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 520 CONTINUE C C *** DO GRADIENT TESTS *** C IF ( V2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 530 IF ( D7TPR(P, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 540 530 V(RADFAC) = V(INCFAC) C C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S *** C 540 CALL V2AXY(PS, Y, NEGONE, Y, G) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL S7LVM(PS, V(TEMP1), V(S1), V(STEP1)) C T1 = ABS( D7TPR(PS, V(STEP1), V(TEMP1))) T = ABS( D7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 550 CALL S7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 560 C 550 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL V7CPY(P, V(G01), V(STEP1)) I = G01 + PS IF (PS .LT. P) CALL V7SCP(P-PS, V(I), ZERO) CALL V7IPR(P, IV(IPIV0), V(G01)) CALL L7TVM(P, V(G01), V(RMAT1), V(G01)) CALL L7VML(P, V(G01), V(RMAT1), V(G01)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL V7IPR(P, IV(IPIV1), V(G01)) C 560 CALL V2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL S7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 180 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 570 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 580 IF (IV(RDREQ) .EQ. 0) GO TO 660 IF (IV(FDH) .NE. 0) GO TO 660 IF (IV(CNVCOD) .GE. 7) GO TO 660 IF (IV(REGD) .GT. 0) GO TO 660 IF (IV(COVMAT) .GT. 0) GO TO 660 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 600 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 590 IV(RESTOR) = 0 600 CALL F7DHB(B, D, G, I, IV, LIV, LV, P, V, X) GO TO (610, 620, 630), I 610 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C 620 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) GO TO 690 C 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120 GO TO 660 C 640 H1 = IABS(IV(H)) IV(FDH) = H1 IV(H) = -H1 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 650 CALL V7CPY(P*(P+1)/2, V(H1), V(HC1)) GO TO 660 650 RMAT1 = IV(RMAT) CALL L7SQR(P, V(H1), V(RMAT1)) C 660 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 670 IV(1) = 1400 GO TO 999 C C *** INCONSISTENT B *** C 680 IV(1) = 82 GO TO 999 C C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G *** C 690 IV(1) = 2 J = IV(IPIVOT) IPI = IV(PERM) CALL I7PNVR(P, IV(IPI), IV(J)) DO 700 I = 1, P IV(J) = I J = J + 1 700 CONTINUE C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 710 DO 720 I = 1, P IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 720 CONTINUE IV(TOOBIG) = 0 C 999 RETURN C C *** LAST LINE OF G7ITB FOLLOWS *** END SUBROUTINE G7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) REAL D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 82. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C G7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND G7LIT BUILDS AN C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD C VECTOR USED IN UPDATING S. G7LIT DECIDES DYNAMICALLY WHETHER OR C NOT TO USE S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR C HC + S (AUGMENTED MODEL). C C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S, G7LIT ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING G7LIT WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY G7LIT OR THE SUBROUTINES IT CALLS. C C WHEN G7LIT IS FIRST CALLED, I.E., WHEN G7LIT IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES, G7LIT RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE G7LIT WILL MAKE A C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL G7LIT AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE G7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME G7LIT RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL G7LIT AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(TOOBIG) TO 1, IN WHICH CASE G7LIT WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1, 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, 2 TEMP1, TEMP2, W1, X01 REAL E, STTSST, T, T1 C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, L7SVX, L7SVN, RLDST, R7MDC, V2NRM EXTERNAL A7SST, D7TPR, F7HES, G7QTS, ITSUM, L7MST, L7SRT, 1 L7SQR, L7SVX, L7SVN, L7TVM, L7VML, PARCK, RLDST, 2 R7MDC, S7LUP, S7LVM, STOPX, V2AXY, V7CPY, V7SCP, 3 V2NRM C C A7SST.... ASSESSES CANDIDATE STEP. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C F7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE). C G7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C L7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C L7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C L7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C L7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C PARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C S7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F, 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS, 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL, 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV, 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR, 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED, 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE, 8 XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/, C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, KAGQT/33/, C 2 KALM/34/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, C 3 MXITER/18/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NFCOV/52/, C 4 NGCOV/53/, NGCALL/30/, NITER/31/, QTR/77/, RADINC/8/, C 5 RDREQ/57/, REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/, C 6 STGLIM/11/, STLSTG/41/, SUSED/64/, SWITCH/12/, TOOBIG/2/, C 7 VNEED/4/, VSAVE/60/, W/65/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56, 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, KAGQT=33, 2 KALM=34, LMAT=42, MODE=35, MODEL=5, MXFCAL=17, 3 MXITER=18, NEXTV=47, NFCALL=6, NFGCAL=7, NFCOV=52, 4 NGCOV=53, NGCALL=30, NITER=31, QTR=77, RADINC=8, 5 RDREQ=57, REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, 6 STGLIM=11, STLSTG=41, SUSED=64, SWITCH=12, TOOBIG=2, 7 VNEED=4, VSAVE=60, W=65, XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/, C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/, C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RCOND/53/, RELDX/17/, SIZE/55/, STPPAR/5/, C 4 TUNER4/29/, TUNER5/30/, WSCALE/56/ C/7 PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45, 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36, 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RCOND=53, RELDX=17, SIZE=55, STPPAR=5, 4 TUNER4=29, TUNER5=30, WSCALE=56) C/ C C C/6 C DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, C 1 ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, 1 ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 40 IF (I .EQ. 2) GO TO 50 C IF (I .EQ. 12 .OR. I .EQ. 13) 1 IV(VNEED) = IV(VNEED) + P*(3*P + 19)/2 + 7 CALL PARCK(1, D, IV, LIV, LV, P, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I C C *** STORAGE ALLOCATION *** C 10 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(W) = IV(DIG) + P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(RESTOR) = 0 IV(FDH) = 0 V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(S) .LT. 0) GO TO 999 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL V7SCP(P*(P+1)/2, V(S1), ZERO) IV(1) = 1 J = IV(IPIVOT) IF (J .LE. 0) GO TO 999 DO 30 I = 1, P IV(J) = I J = J + 1 30 CONTINUE GO TO 999 C C *** NEW FUNCTION VALUE *** C 40 IF (IV(MODE) .EQ. 0) GO TO 290 IF (IV(MODE) .GT. 0) GO TO 520 C IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 999 C C *** NEW GRADIENT *** C 50 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 520 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 65 GO TO 999 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610 C C *** COMPUTE D**-1 * GRADIENT *** C DIG1 = IV(DIG) K = DIG1 DO 70 I = 1, P V(K) = G(I) / D(I) K = K + 1 70 CONTINUE V(DGNORM) = V2NRM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 510 IF (IV(MODE) .EQ. 0) GO TO 440 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 100 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 530 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 80 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 90 CALL V2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 100 90 RMAT1 = IV(RMAT) CALL L7SQR(PS, V(S1), V(RMAT1)) CALL V2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1)) 100 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 110 CALL ITSUM(D, G, IV, LIV, LV, P, V, X) 120 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 130 IV(1) = 10 GO TO 999 130 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 150 STEP1 = IV(STEP) DO 140 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 140 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * V2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 150 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL V7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 160 IF (.NOT. STOPX(DUMMY)) GO TO 180 IV(1) = 11 GO TO 190 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 170 IF (V(F) .GE. V(F0)) GO TO 180 V(RADFAC) = ONE K = IV(NITER) GO TO 130 C 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200 IV(1) = 9 190 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 430 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 200 STEP1 = IV(STEP) W1 = IV(W) H1 = IV(H) T1 = ONE IF (IV(MODEL) .EQ. 2) GO TO 210 T1 = ZERO C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 210 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 210 IPIV1 = IV(IPIVOT) CALL L7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1), 1 V(RMAT1), V(STEP1), V, V(W1)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION G7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 260 C 210 IF (H1 .GT. 0) GO TO 250 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C H1 = -H1 IV(H) = H1 IV(FDH) = 0 J = IV(HC) IF (J .GT. 0) GO TO 220 J = H1 RMAT1 = IV(RMAT) CALL L7SQR(P, V(H1), V(RMAT1)) 220 S1 = IV(S) DO 240 I = 1, P T = ONE / D(I) DO 230 K = 1, I V(H1) = T * (V(J) + T1*V(S1)) / D(K) J = J + 1 H1 = H1 + 1 S1 = S1 + 1 230 CONTINUE 240 CONTINUE H1 = IV(H) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 250 DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL G7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), 1 V, V(W1)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 260 IF (IV(IRC) .NE. 6) GO TO 270 IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 2 GO TO 300 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 270 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 290 IF (IV(IRC) .NE. 5) GO TO 280 IF (V(RADFAC) .LE. ONE) GO TO 280 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280 STEP1 = IV(STEP) X01 = IV(X0) CALL V2AXY(P, V(STEP1), NEGONE, V(X01), X) IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 0 GO TO 300 C C *** COMPUTE F(X0 + STEP) *** C 280 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 290 RSTRST = 3 300 X01 = IV(X0) V(RELDX) = RLDST(P, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (340, 310, 320, 330), I 310 CALL V7CPY(P, X, V(X01)) GO TO 340 320 CALL V7CPY(P, V(LSTGST), V(STEP1)) GO TO 340 330 CALL V7CPY(P, V(STEP1), V(LSTGST)) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = RLDST(P, D, X, V(X01)) IV(RESTOR) = RSTRST C C *** IF NECESSARY, SWITCH MODELS *** C 340 IF (IV(SWITCH) .EQ. 0) GO TO 350 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V, V(L)) 350 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL S7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * D7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 360 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 400 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V(L), V) GO TO 160 C 360 IF (-3 .LT. L) GO TO 400 C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 370 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 160 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST C 380 V(RADIUS) = V(LMAXS) GO TO 200 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 390 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 510 IF (IV(XIRC) .EQ. 14) GO TO 510 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 400 IV(COVMAT) = 0 IV(REGD) = 0 C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C IF (IV(IRC) .NE. 3) GO TO 430 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(W) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 410 CALL S7LVM(P, V(TEMP1), V(HC1), V(STEP1)) GO TO 420 410 RMAT1 = IV(RMAT) CALL L7TVM(P, V(TEMP1), V(RMAT1), V(STEP1)) CALL L7VML(P, V(TEMP1), V(RMAT1), V(TEMP1)) C 420 IF (STPMOD .EQ. 1) GO TO 430 S1 = IV(S) CALL S7LVM(PS, V(TEMP2), V(S1), V(STEP1)) CALL V2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1)) C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 430 IV(NGCALL) = IV(NGCALL) + 1 G01 = IV(W) CALL V7CPY(P, V(G01), G) IV(1) = 2 IV(TOOBIG) = 0 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 440 G01 = IV(W) CALL V2AXY(P, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(W) IF (IV(IRC) .NE. 3) GO TO 470 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 450 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 450 CONTINUE C C *** DO GRADIENT TESTS *** C IF ( V2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 460 IF ( D7TPR(P, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 470 460 V(RADFAC) = V(INCFAC) C C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S *** C 470 CALL V2AXY(PS, Y, NEGONE, Y, G) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL S7LVM(PS, V(TEMP1), V(S1), V(STEP1)) C T1 = ABS( D7TPR(PS, V(STEP1), V(TEMP1))) T = ABS( D7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL S7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 490 C 480 RMAT1 = IV(RMAT) CALL L7TVM(PS, V(G01), V(RMAT1), V(STEP1)) CALL L7VML(PS, V(G01), V(RMAT1), V(G01)) C 490 CALL V2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL S7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 110 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 500 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 510 IF (IV(RDREQ) .EQ. 0) GO TO 600 IF (IV(FDH) .NE. 0) GO TO 600 IF (IV(CNVCOD) .GE. 7) GO TO 600 IF (IV(REGD) .GT. 0) GO TO 600 IF (IV(COVMAT) .GT. 0) GO TO 600 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 530 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 520 IV(RESTOR) = 0 530 CALL F7HES(D, G, I, IV, LIV, LV, P, V, X) GO TO (540, 550, 580), I 540 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C 550 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) IV(1) = 2 GO TO 999 C 560 H1 = IABS(IV(H)) IV(H) = -H1 PP1O2 = P * (P + 1) / 2 RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 570 LMAT1 = IV(LMAT) CALL V7CPY(PP1O2, V(LMAT1), V(RMAT1)) V(RCOND) = ZERO GO TO 590 570 HC1 = IV(HC) IV(FDH) = H1 CALL V7CPY(P*(P+1)/2, V(H1), V(HC1)) C C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN C *** FOR USE IN CALLER*S COVARIANCE CALCULATION... C 580 LMAT1 = IV(LMAT) H1 = IV(FDH) IF (H1 .LE. 0) GO TO 600 IF (IV(CNVCOD) .EQ. 70) GO TO 80 CALL L7SRT(1, P, V(LMAT1), V(H1), I) IV(FDH) = -1 V(RCOND) = ZERO IF (I .NE. 0) GO TO 600 C 590 IV(FDH) = -1 STEP1 = IV(STEP) T = L7SVN(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .LE. ZERO) GO TO 600 T = T / L7SVX(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .GT. R7MDC(4)) IV(FDH) = H1 V(RCOND) = T C 600 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 610 IV(1) = 1400 C 999 RETURN C C *** LAST LINE OF G7LIT FOLLOWS *** END SUBROUTINE G7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV, 1 P, P0, PC, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) REAL B(2,P), D(P), DIHDI(1), G(P), L(1), 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2) C REAL D7TPR EXTERNAL D7TPR, G7QTS, S7BQN, S7IPR, V7CPY, V7IPR, 1 V7SCP, V7VMP C C *** LOCAL VARIABLES *** C INTEGER K, KB, KINIT, NS, P1, P10 REAL DS0, NRED, PRED, RAD REAL ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C C/6 C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/, C 1 RADIUS/8/ C/7 PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) C/ DATA ZERO/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C P1 = PC IF (KA .LT. 0) GO TO 10 NRED = V(NREDUC) DS0 = V(DST0) GO TO 20 10 P0 = 0 KA = -1 C 20 KINIT = -1 IF (P0 .EQ. P1) KINIT = KA CALL V7CPY(P, X, X0) PRED = ZERO RAD = V(RADIUS) KB = -1 V(DSTNRM) = ZERO IF (P1 .GT. 0) GO TO 30 NRED = ZERO DS0 = ZERO CALL V7SCP(P, STEP, ZERO) GO TO 60 C 30 CALL V7CPY(P, TD, D) CALL V7IPR(P, IPIV, TD) CALL V7VMP(P, TG, G, D, -1) CALL V7IPR(P, IPIV, TG) 40 K = KINIT KINIT = -1 V(RADIUS) = RAD - V(DSTNRM) CALL G7QTS(TD, TG, DIHDI, K, L, P1, STEP, V, W) P0 = P1 IF (KA .GE. 0) GO TO 50 NRED = V(NREDUC) DS0 = V(DST0) C 50 KA = K V(RADIUS) = RAD P10 = P1 CALL S7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, L, LV, 1 NS, P, P1, STEP, TD, TG, V, W, X, X0) IF (NS .GT. 0) CALL S7IPR(P10, IPIV1, DIHDI) PRED = PRED + V(PREDUC) IF (NS .NE. 0) P0 = 0 IF (KB .LE. 0) GO TO 40 C 60 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = D7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF G7QSB FOLLOWS *** END SUBROUTINE G7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W) C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN *** C C *** PARAMETER DECLARATIONS *** C INTEGER KA, P REAL D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C (G7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT C CALL THIS ROUTINE. C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C D7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C L7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C L7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C L7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C L7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C R7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS. C V2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB. C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL RESTRT INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X REAL ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK, 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ, 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI C C *** CONSTANTS *** REAL BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, 1 ONE, P001, SIX, THREE, TWO, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, L7SVN, R7MDC, V2NRM EXTERNAL D7TPR, L7ITV, L7IVM, L7SRT, L7SVN, R7MDC, V2NRM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC, 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0 C/6 C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/, C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/, C 2 RAD0/9/, STPPAR/5/ C/7 PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4, 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8, 2 RAD0=9, STPPAR=5) C/ C C/6 C DATA EPSFAC/50.0E+0/, FOUR/4.0E+0/, HALF/0.5E+0/, C 1 KAPPA/2.0E+0/, NEGONE/-1.0E+0/, ONE/1.0E+0/, P001/1.0E-3/, C 2 SIX/6.0E+0/, THREE/3.0E+0/, TWO/2.0E+0/, ZERO/0.0E+0/ C/7 PARAMETER (EPSFAC=50.0E+0, FOUR=4.0E+0, HALF=0.5E+0, 1 KAPPA=2.0E+0, NEGONE=-1.0E+0, ONE=1.0E+0, P001=1.0E-3, 2 SIX=6.0E+0, THREE=3.0E+0, TWO=2.0E+0, ZERO=0.0E+0) SAVE DGXFAC C/ DATA BIG/0.E+0/, DGXFAC/0.E+0/ C C *** BODY *** C IF (BIG .LE. ZERO) BIG = R7MDC(6) C C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX). DGGDMX = P + 1 C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX) C *** AND W(EMIN) RESPECTIVELY. EMAX = DGGDMX + 1 EMIN = EMAX + 1 C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST, C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF. C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN) C *** RESPECTIVELY. LK0 = EMIN + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P). DIAG0 = DSTSAV DIAG = DIAG0 + 1 C *** STORE -D*STEP IN W(Q),...,W(Q0+P). Q0 = DIAG0 + P Q = Q0 + 1 C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X *** X = Q + P RAD = V(RADIUS) RADSQ = RAD**2 C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF C *** D*STEP. PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD PSIFAC = BIG T1 = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) * 1 (KAPPA + ONE) + KAPPA + TWO) * RAD) IF (T1 .LT. BIG*AMIN1(RAD,ONE)) PSIFAC = T1 / RAD C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO EPS = V(EPSLON) IRC = 0 RESTRT = .FALSE. KALIM = KA + 50 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA .GE. 0) GO TO 290 C C *** FRESH START *** C K = 0 UK = NEGONE KA = 0 KALIM = 50 V(DGNORM) = V2NRM(P, DIG) V(NREDUC) = ZERO V(DST0) = ZERO KAMIN = 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 C C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) *** C J = 0 DO 10 I = 1, P J = J + I K1 = DIAG0 + I W(K1) = DIHDI(J) 10 CONTINUE C C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI *** C T1 = ZERO J = P * (P + 1) / 2 DO 20 I = 1, J T = ABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 20 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 30 CALL L7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 50 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 40 I = 1, IRC 40 W(I) = ZERO W(IRC) = ONE CALL L7ITV(IRC, W, L, W) T1 = V2NRM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 50 LK = ZERO T = L7SVN(P, L, W(Q), W(Q)) IF (T .GE. ONE) GO TO 60 IF (V(DGNORM) .GE. T*T*BIG) GO TO 70 60 CALL L7IVM(P, W(Q), L, DIG) GTSTA = D7TPR(P, W(Q), W(Q)) V(NREDUC) = HALF * GTSTA CALL L7ITV(P, W(Q), L, W(Q)) DST = V2NRM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 260 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = ABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = AMAX1(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = AMIN1(UK, AMAX1(ALPHAK, LK)) C IF (IRC .NE. 0) GO TO 210 C C *** COMPUTE L0 FOR POSITIVE DEFINITE H *** C CALL L7IVM(P, W, L, W(Q)) T = V2NRM(P, W) W(PHIPIN) = RAD / T / T LK = AMAX1(LK, PHI*W(PHIPIN)) C C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) *** C 210 KA = KA + 1 IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * AMAX1(P001, SQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK IF (ALPHAK .LE. ZERO) ALPHAK = UK K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL L7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 240 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL L7ITV(IRC, W, L, W) T1 = V2NRM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK IF (UK .LT. LK) UK = LK IF (ALPHAK .LT. LK) GO TO 210 C C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK... C T = P001 * ALPHAK IF (T .LE. ZERO) T = P001 LK = ALPHAK + T IF (UK .LE. LK) UK = LK + T GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 240 CALL L7IVM(P, W(Q), L, DIG) GTSTA = D7TPR(P, W(Q), W(Q)) CALL L7ITV(P, W(Q), L, W(Q)) DST = V2NRM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270 IF (PHI .EQ. OLDPHI) GO TO 270 OLDPHI = PHI IF (PHI .LT. ZERO) GO TO 330 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 250 IF (KA .GE. KALIM) GO TO 270 C *** THE FOLLOWING AMIN1 IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK) C *** KAMIN = 0 ONLY IFF THE GRADIENT VANISHES *** IF (KAMIN .EQ. 0) GO TO 210 CALL L7IVM(P, W, L, W(Q)) C *** THE FOLLOWING, COMMENTED CALCULATION OF ALPHAK IS SOMETIMES C *** SAFER BUT WORSE IN PERFORMANCE... C T1 = DST / V2NRM(P, W) C ALPHAK = ALPHAK + T1 * (PHI/RAD) * T1 T1 = V2NRM(P, W) ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD) LK = AMAX1(LK, ALPHAK) ALPHAK = LK GO TO 210 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 260 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 270 DO 280 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 280 CONTINUE V(GTSTEP) = -GTSTA V(PREDUC) = HALF * ( ABS(ALPHAK)*DST*DST + GTSTA) GO TO 410 C C C *** RESTART WITH NEW RADIUS *** C 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 300 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 300 CONTINUE UK = NEGONE GO TO 30 C 310 KAMIN = KA + 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 IF (KA .EQ. 0) GO TO 50 C DST = W(DSTSAV) ALPHAK = ABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD UK = T - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 IF (RAD .GT. V(RAD0)) GO TO 320 C C *** SMALLER RADIUS *** LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = AMAX1(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 250 C C *** BIGGER RADIUS *** 320 IF (ALPHAK .GT. ZERO) UK = AMIN1(UK, W(UK0)) LK = AMAX1(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 250 C C *** DECIDE WHETHER TO CHECK FOR SPECIAL CASE... IN PRACTICE (FROM C *** THE STANDPOINT OF THE CALLING OPTIMIZATION CODE) IT SEEMS BEST C *** NOT TO CHECK UNTIL A FEW ITERATIONS HAVE FAILED -- HENCE THE C *** TEST ON KAMIN BELOW. C 330 DELTA = ALPHAK + AMIN1(ZERO, V(DST0)) TWOPSI = ALPHAK*DST*DST + GTSTA IF (KA .GE. KAMIN) GO TO 340 C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS C *** IT). IF (PSIFAC .GE. BIG) GO TO 340 IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370 C C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. USE ONE STEP OF INVERSE POWER METHOD WITH START C *** FROM L7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). L7SVN RETURNS C *** X AND W WITH L*W = X. C 340 T = L7SVN(P, L, W(X), W) C C *** NORMALIZE W *** DO 350 I = 1, P 350 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL L7ITV(P, W, L, W) T2 = ONE/ V2NRM(P, W) DO 360 I = 1, P 360 W(I) = T2*W(I) T = T2 * T C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = D7TPR(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = SQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C C *** THE ACTUAL TEST FOR THE SPECIAL CASE... C IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380 C C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE) C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE... C IF (V(DST0) .LE. ZERO) V(DST0) = AMIN1(V(DST0), T2**2 - ALPHAK) LK = AMAX1(LK, -V(DST0)) C C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT. C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * R7MDC(3) C IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250 GO TO 270 C C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE C 380 ALPHAK = -ALPHAK V(PREDUC) = HALF * TWOPSI C C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. C T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T* D7TPR(P,W(X),W))) IF (T .LT. EPS*TWOPSI/SIX) GO TO 390 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 390 DO 400 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 400 CONTINUE V(GTSTEP) = D7TPR(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 410 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 420 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 420 CONTINUE C 999 RETURN C C *** LAST CARD OF G7QTS FOLLOWS *** END SUBROUTINE H2RFA(N, A, B, X, Y, Z) C C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO C *** N-VECTORS A, B *** C INTEGER N REAL A(N), B(N), X, Y, Z INTEGER I REAL T DO 10 I = 1, N T = A(I)*X + B(I)*Y A(I) = A(I) + T B(I) = B(I) + T*Z 10 CONTINUE 999 RETURN C *** LAST LINE OF H2RFA FOLLOWS *** END REAL FUNCTION H2RFG(A, B, X, Y, Z) C C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2 C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T, C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE H2RFG C *** RETURNS. C REAL A, B, X, Y, Z C REAL A1, B1, C, T C/+ REAL SQRT C/ REAL ZERO DATA ZERO/0.E+0/ C C *** BODY *** C IF (B .NE. ZERO) GO TO 10 X = ZERO Y = ZERO Z = ZERO H2RFG = A GO TO 999 10 T = ABS(A) + ABS(B) A1 = A / T B1 = B / T C = SQRT(A1**2 + B1**2) IF (A1 .GT. ZERO) C = -C A1 = A1 - C Z = B1 / A1 X = A1 / C Y = B1 / C H2RFG = T * C 999 RETURN C *** LAST LINE OF H2RFG FOLLOWS *** END SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, X IGH,ITN,ITS,LOW,MP2,ENM2,IERR REAL H(NM,N),WR(N),WI(N),Z(NM,N) REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2 COMPLEX Z3 LOGICAL NOTLAS C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C H CONTAINS THE UPPER HESSENBERG MATRIX. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE C IDENTITY MATRIX. C C ON OUTPUT C C H HAS BEEN DESTROYED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C THIS ROUTINE IS FROM EISPACK (VERSION DATED AUGUST 1983), WITH C CALLS ON CDIV REPLACED BY COMPLEX DIVISION. C C ------------------------------------------------------------------ C IERR = 0 NORM = 0.0E0 K = 1 C .......... STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM .......... DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.0E0 50 CONTINUE C EN = IGH T = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUES .......... 60 IF (EN .LT. LOW) GO TO 340 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) IF (S .EQ. 0.0E0) S = NORM TST1 = S TST2 = TST1 + ABS(H(L,L-1)) IF (TST2 .EQ. TST1) GO TO 100 80 CONTINUE C .......... FORM SHIFT .......... 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C .......... FORM EXCEPTIONAL SHIFT .......... T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75E0 * S Y = X W = -0.4375E0 * S * S 130 ITS = ITS + 1 ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = ABS(P) + ABS(Q) + ABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 TST1 = ABS(P)*(ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1))) TST2 = TST1 + ABS(H(M,M-1))*(ABS(Q) + ABS(R)) IF (TST2 .EQ. TST1) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.0E0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.0E0 160 CONTINUE C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN .......... DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0E0 IF (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) IF (X .EQ. 0.0E0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P IF (NOTLAS) GO TO 225 C .......... ROW MODIFICATION .......... DO 200 J = K, N P = H(K,J) + Q * H(K+1,J) H(K,J) = H(K,J) - P * X H(K+1,J) = H(K+1,J) - P * Y 200 CONTINUE C J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... DO 210 I = 1, J P = X * H(I,K) + Y * H(I,K+1) H(I,K) = H(I,K) - P H(I,K+1) = H(I,K+1) - P * Q 210 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 220 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) Z(I,K) = Z(I,K) - P Z(I,K+1) = Z(I,K+1) - P * Q 220 CONTINUE GO TO 255 225 CONTINUE C .......... ROW MODIFICATION .......... DO 230 J = K, N P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) H(K,J) = H(K,J) - P * X H(K+1,J) = H(K+1,J) - P * Y H(K+2,J) = H(K+2,J) - P * ZZ 230 CONTINUE C J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... DO 240 I = 1, J P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) H(I,K) = H(I,K) - P H(I,K+1) = H(I,K+1) - P * Q H(I,K+2) = H(I,K+2) - P * R 240 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 250 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2) Z(I,K) = Z(I,K) - P Z(I,K+1) = Z(I,K+1) - P * Q Z(I,K+2) = Z(I,K+2) - P * R 250 CONTINUE 255 CONTINUE C 260 CONTINUE C GO TO 70 C .......... ONE ROOT FOUND .......... 270 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.0E0 EN = NA GO TO 60 C .......... TWO ROOTS FOUND .......... 280 P = (Y - X) / 2.0E0 Q = P * P + W ZZ = SQRT(ABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.0E0) GO TO 320 C .......... REAL PAIR .......... ZZ = P + SIGN(ZZ,P) WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ WI(NA) = 0.0E0 WI(EN) = 0.0E0 X = H(EN,NA) S = ABS(X) + ABS(ZZ) P = X / S Q = ZZ / S R = SQRT(P*P+Q*Q) P = P / R Q = Q / R C .......... ROW MODIFICATION .......... DO 290 J = NA, N ZZ = H(NA,J) H(NA,J) = Q * ZZ + P * H(EN,J) H(EN,J) = Q * H(EN,J) - P * ZZ 290 CONTINUE C .......... COLUMN MODIFICATION .......... DO 300 I = 1, EN ZZ = H(I,NA) H(I,NA) = Q * ZZ + P * H(I,EN) H(I,EN) = Q * H(I,EN) - P * ZZ 300 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 310 I = LOW, IGH ZZ = Z(I,NA) Z(I,NA) = Q * ZZ + P * Z(I,EN) Z(I,EN) = Q * Z(I,EN) - P * ZZ 310 CONTINUE C GO TO 330 C .......... COMPLEX PAIR .......... 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM .......... 340 IF (NORM .EQ. 0.0E0) GO TO 1001 C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... DO 800 NN = 1, N EN = N + 1 - NN P = WR(EN) Q = WI(EN) NA = EN - 1 IF (Q) 710, 600, 800 C .......... REAL VECTOR .......... 600 M = EN H(EN,EN) = 1.0E0 IF (NA .EQ. 0) GO TO 800 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 700 II = 1, NA I = EN - II W = H(I,I) - P R = 0.0E0 C DO 610 J = M, EN 610 R = R + H(I,J) * H(J,EN) C IF (WI(I) .GE. 0.0E0) GO TO 630 ZZ = W S = R GO TO 700 630 M = I IF (WI(I) .NE. 0.0E0) GO TO 640 T = W IF (T .NE. 0.0E0) GO TO 635 TST1 = NORM T = TST1 632 T = 0.01E0 * T TST2 = NORM + T IF (TST2 .GT. TST1) GO TO 632 635 H(I,EN) = -R / T GO TO 680 C .......... SOLVE REAL EQUATIONS .......... 640 X = H(I,I+1) Y = H(I+1,I) Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) T = (X * S - ZZ * R) / Q H(I,EN) = T IF (ABS(X) .LE. ABS(ZZ)) GO TO 650 H(I+1,EN) = (-R - W * T) / X GO TO 680 650 H(I+1,EN) = (-S - Y * T) / ZZ C C .......... OVERFLOW CONTROL .......... 680 T = ABS(H(I,EN)) IF (T .EQ. 0.0E0) GO TO 700 TST1 = T TST2 = TST1 + 1.0E0/TST1 IF (TST2 .GT. TST1) GO TO 700 DO 690 J = I, EN H(J,EN) = H(J,EN)/T 690 CONTINUE C 700 CONTINUE C .......... END REAL VECTOR .......... GO TO 800 C .......... COMPLEX VECTOR .......... 710 M = NA C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT C EIGENVECTOR MATRIX IS TRIANGULAR .......... IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720 H(NA,NA) = Q / H(EN,NA) H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) GO TO 730 720 Z3 = CMPLX(0.0,-H(NA,EN)) / CMPLX(H(NA,NA)-P,Q) H(NA,NA) = REAL(Z3) H(NA,EN) = AIMAG(Z3) 730 H(EN,NA) = 0.0E0 H(EN,EN) = 1.0E0 ENM2 = NA - 1 IF (ENM2 .EQ. 0) GO TO 800 C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... DO 795 II = 1, ENM2 I = NA - II W = H(I,I) - P RA = 0.0E0 SA = 0.0E0 C DO 760 J = M, EN RA = RA + H(I,J) * H(J,NA) SA = SA + H(I,J) * H(J,EN) 760 CONTINUE C IF (WI(I) .GE. 0.0E0) GO TO 770 ZZ = W R = RA S = SA GO TO 795 770 M = I IF (WI(I) .NE. 0.0E0) GO TO 780 Z3 = CMPLX(-RA,-SA) / CMPLX(W,Q) H(I,NA) = REAL(Z3) H(I,EN) = AIMAG(Z3) GO TO 790 C .......... SOLVE COMPLEX EQUATIONS .......... 780 X = H(I,I+1) Y = H(I+1,I) VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q VI = (WR(I) - P) * 2.0E0 * Q IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 784 TST1 = NORM * (ABS(W) + ABS(Q) + ABS(X) X + ABS(Y) + ABS(ZZ)) VR = TST1 783 VR = 0.01E0 * VR TST2 = TST1 + VR IF (TST2 .GT. TST1) GO TO 783 784 Z3 = CMPLX(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA) / CMPLX(VR,VI) H(I,NA) = REAL(Z3) H(I,EN) = AIMAG(Z3) IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785 H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X GO TO 790 785 Z3 = CMPLX(-R-Y*H(I,NA),-S-Y*H(I,EN)) / CMPLX(ZZ,Q) H(I+1,NA) = REAL(Z3) H(I+1,EN) = AIMAG(Z3) C C .......... OVERFLOW CONTROL .......... 790 T = AMAX1(ABS(H(I,NA)), ABS(H(I,EN))) IF (T .EQ. 0.0E0) GO TO 795 TST1 = T TST2 = TST1 + 1.0E0/TST1 IF (TST2 .GT. TST1) GO TO 795 DO 792 J = I, EN H(J,NA) = H(J,NA)/T H(J,EN) = H(J,EN)/T 792 CONTINUE C 795 CONTINUE C .......... END COMPLEX VECTOR .......... 800 CONTINUE C .......... END BACK SUBSTITUTION. C VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 C DO 820 J = I, N 820 Z(I,J) = H(I,J) C 840 CONTINUE C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW DO -- .......... DO 880 JJ = LOW, N J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZ = 0.0E0 C DO 860 K = LOW, M 860 ZZ = ZZ + Z(I,K) * H(K,J) C Z(I,J) = ZZ 880 CONTINUE C GO TO 1001 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE I0TK00(LARG,NITEMS,ITYPE) C C INITIALIZES THE STACK TO NITEMS OF TYPE ITYPE C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) LOGICAL LARG,INIT INTEGER ISIZE(5) C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),LOUT) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),ISIZE(1)) C DATA INIT/.FALSE./ C LARG = .FALSE. IF (INIT) RETURN C C HERE TO INITIALIZE C INIT = .TRUE. C C SET DATA SIZES APPROPRIATE FOR A STANDARD CONFORMING C FORTRAN SYSTEM USING THE FORTRAN STORAGE UNIT AS THE C MEASURE OF SIZE. C C LOGICAL ISIZE(1) = 1 C INTEGER ISIZE(2) = 1 C REAL ISIZE(3) = 1 C DOUBLE PRECISION ISIZE(4) = 2 C COMPLEX ISIZE(5) = 2 C LBOOK = 10 LNOW = LBOOK LUSED = LBOOK LMAX = MAX0( (NITEMS*ISIZE(ITYPE))/ISIZE(2), 12 ) LOUT = 0 C RETURN C END SUBROUTINE I0TK01 C LOGICAL DONE C DATA DONE /.FALSE./ C IF(DONE) RETURN DONE = .TRUE. IUNIT = I1MACH(4) C WRITE( IUNIT, 100) WRITE( IUNIT, 200) WRITE( IUNIT, 300) C RETURN C 100 FORMAT (1H1, *62H YOU HAVE USED, DIRECTLY OR INDIRECTLY, ONE OF THE STORAGE AL-/ *62H LOCATION PROGRAMS IALLOC, DALLOC, STINIT, NIRALL, MTSTAK OR/ *62H SRECAP. THESE ARE BASED ON THE ASSUMPTION THAT ONE -UNIT- OF/ *62H STORAGE IS ALLOCATED TO DATA OF TYPE LOGICAL, INTEGER AND/ *62H REAL AND THAT TWO -UNITS- OF STORAGE ARE ALLOCATED TO DATA OF/ *62H TYPE DOUBLE PRECISION AND COMPLEX. THIS ASSUMPTION PREVENTS/ *62H MOVING PORT TO MANY MINI-COMPUTERS. / *62H / *62H TO OVERCOME THIS DIFFICULTY, THE PACKAGE HAS BEEN REWRITTEN/ *62H WITH NEW NAMES AND SIMILAR CALLING SEQUENCES. CALLS TO THE/ *62H OLD SUBPROGRAMS SHOULD BE REPLACED BY CALLS TO THE NEW/ *62H PACKAGE WHEN CONVENIENT. TO AVOID OBSOLETING OLD PROGRAMS/ *62H THE OLD CALLING SEQUENCES WILL CONTINUE TO BE SUPPORTED. / *62H / *) C 200 FORMAT( *62H THE OLD AND NEW CALLING SEQUENCES ARE AS FOLLOWS- / *62H / *62H FUNCTION OLD NEW / *62H / *62H GET IX = IALLOC(NDATA,ISIZE) IX = ISTKGT(NDATA,ITYPE)/ *62H RELEASE CALL DALLOC(NFRAMES) CALL ISTKRL(NFRAMES) / *62H INITIALIZE CALL STINIT(NDATA,ISIZE) CALL ISTKIN(NDATA,ITYPE)/ *62H MODIFY IX = MTSTAK(NDATA) IX = ISTKMD(NDATA) / *62H STATISTICS CALL SRECAP(IUNIT) - NO EQUIVALENT - / *62H QUERY N = NIRALL(ISIZE) N = ISTKQU(ITYPE) / *62H / *) C 300 FORMAT( *62H IN THE ABOVE ITYPE IS AS FOLLOWS- / *62H / *62H 1 LOGICAL / *62H 2 INTEGER / *62H 3 REAL / *62H 4 DOUBLE PRECISION / *62H 5 COMPLEX / *62H / *62H NOTE ALSO THAT ALLOCATIONS SHOULD NOT BE SPLIT INTO SUBAL-/ *62H LOCATIONS OF DIFFERENT TYPE AS THIS ALSO COMPROMISES POR-/ *62H TABILITY. / *) C END INTEGER FUNCTION I10WID(IX) INTEGER IX INTEGER IABS, IY, DIGITS C THIS FUNCTION RETURNS THE NUMBER OF DECIMAL C DIGITS REQUIRED TO REPRESENT THE INTEGER, IX. DIGITS = 0 IY = IABS(IX) 1 IF (IY .LT. 1) GOTO 2 DIGITS = DIGITS+1 IY = IY/10 GOTO 1 2 I10WID = DIGITS RETURN END INTEGER FUNCTION I1MACH(I) INTEGER I C C I1MACH( 1) = THE STANDARD INPUT UNIT. C I1MACH( 2) = THE STANDARD OUTPUT UNIT. C I1MACH( 3) = THE STANDARD PUNCH UNIT. C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C I1MACH( 7) = A, THE BASE. C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. C FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C WHERE EMIN .LE. E .LE. EMAX. C I1MACH(10) = B, THE BASE. C SINGLE-PRECISION C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. C DOUBLE-PRECISION C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. C INTEGER IMACH(16), OUTPUT, SC, SMALL(2) SAVE IMACH, SC REAL RMACH EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1)) INTEGER I3, J, K, T3E(3) DATA T3E(1) / 9777664 / DATA T3E(2) / 5323660 / DATA T3E(3) / 46980 / C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES, C INCLUDING AUTO-DOUBLE COMPILERS. C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 C ON THE NEXT LINE DATA SC/0/ C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY C mail netlib@research.bell-labs.com C send old1mach from blas C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 43 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 63 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 60 / C DATA IMACH(15) /-1024 / C DATA IMACH(16) / 1023 /, SC/987/ C IF (SC .NE. 987) THEN * *** CHECK FOR AUTODOUBLE *** SMALL(2) = 0 RMACH = 1E13 IF (SMALL(2) .NE. 0) THEN * *** AUTODOUBLED *** IF ( (SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) * .OR. (SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528)) THEN * *** IEEE *** IMACH(10) = 2 IMACH(14) = 53 IMACH(15) = -1021 IMACH(16) = 1024 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** IMACH(10) = 2 IMACH(14) = 56 IMACH(15) = -127 IMACH(16) = 127 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** IMACH(10) = 16 IMACH(14) = 14 IMACH(15) = -64 IMACH(16) = 63 ELSE WRITE(*,9010) STOP 777 END IF IMACH(11) = IMACH(14) IMACH(12) = IMACH(15) IMACH(13) = IMACH(16) ELSE RMACH = 1234567. IF (SMALL(1) .EQ. 1234613304) THEN * *** IEEE *** IMACH(10) = 2 IMACH(11) = 24 IMACH(12) = -125 IMACH(13) = 128 IMACH(14) = 53 IMACH(15) = -1021 IMACH(16) = 1024 SC = 987 ELSE IF (SMALL(1) .EQ. -1271379306) THEN * *** VAX *** IMACH(10) = 2 IMACH(11) = 24 IMACH(12) = -127 IMACH(13) = 127 IMACH(14) = 56 IMACH(15) = -127 IMACH(16) = 127 SC = 987 ELSE IF (SMALL(1) .EQ. 1175639687) THEN * *** IBM MAINFRAME *** IMACH(10) = 16 IMACH(11) = 6 IMACH(12) = -64 IMACH(13) = 63 IMACH(14) = 14 IMACH(15) = -64 IMACH(16) = 63 SC = 987 ELSE IF (SMALL(1) .EQ. 1251390520) THEN * *** CONVEX C-1 *** IMACH(10) = 2 IMACH(11) = 24 IMACH(12) = -128 IMACH(13) = 127 IMACH(14) = 53 IMACH(15) = -1024 IMACH(16) = 1023 ELSE DO 10 I3 = 1, 3 J = SMALL(1) / 10000000 K = SMALL(1) - 10000000*J IF (K .NE. T3E(I3)) GO TO 20 SMALL(1) = J 10 CONTINUE * *** CRAY T3E *** IMACH( 1) = 5 IMACH( 2) = 6 IMACH( 3) = 0 IMACH( 4) = 0 IMACH( 5) = 64 IMACH( 6) = 8 IMACH( 7) = 2 IMACH( 8) = 63 CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215) IMACH(10) = 2 IMACH(11) = 53 IMACH(12) = -1021 IMACH(13) = 1024 IMACH(14) = 53 IMACH(15) = -1021 IMACH(16) = 1024 GO TO 35 20 CALL I1MCR1(J, K, 16405, 9876536, 0) IF (SMALL(1) .NE. J) THEN WRITE(*,9020) STOP 777 END IF * *** CRAY 1, XMP, 2, AND 3 *** IMACH(1) = 5 IMACH(2) = 6 IMACH(3) = 102 IMACH(4) = 6 IMACH(5) = 46 IMACH(6) = 8 IMACH(7) = 2 IMACH(8) = 45 CALL I1MCR1(IMACH(9), K, 0, 4194303, 16777215) IMACH(10) = 2 IMACH(11) = 47 IMACH(12) = -8188 IMACH(13) = 8189 IMACH(14) = 94 IMACH(15) = -8141 IMACH(16) = 8189 GO TO 35 END IF END IF IMACH( 1) = 5 IMACH( 2) = 6 IMACH( 3) = 7 IMACH( 4) = 6 IMACH( 5) = 32 IMACH( 6) = 4 IMACH( 7) = 2 IMACH( 8) = 31 IMACH( 9) = 2147483647 35 SC = 987 END IF 9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/ * ' statements appropriate for your machine and setting'/ * ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.') 9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/ * ' appropriate for your machine.') IF (I .LT. 1 .OR. I .GT. 16) GO TO 40 I1MACH = IMACH(I) RETURN 40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.' STOP * /* C source for I1MACH -- remove the * in column 1 */ * /* Note that some values may need changing. */ *#include *#include *#include *#include * *long i1mach_(long *i) *{ * switch(*i){ * case 1: return 5; /* standard input */ * case 2: return 6; /* standard output */ * case 3: return 7; /* standard punch */ * case 4: return 0; /* standard error */ * case 5: return 32; /* bits per integer */ * case 6: return sizeof(int); * case 7: return 2; /* base for integers */ * case 8: return 31; /* digits of integer base */ * case 9: return LONG_MAX; * case 10: return FLT_RADIX; * case 11: return FLT_MANT_DIG; * case 12: return FLT_MIN_EXP; * case 13: return FLT_MAX_EXP; * case 14: return DBL_MANT_DIG; * case 15: return DBL_MIN_EXP; * case 16: return DBL_MAX_EXP; * } * fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); * exit(1);return 0; /* some compilers demand return values */ *} END SUBROUTINE I1MCR1(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END SUBROUTINE I7COPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE INTEGER P-VECTORS *** C INTEGER P INTEGER X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) 999 RETURN END SUBROUTINE I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA) INTEGER M,N,MAXCLQ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),LIST(N), * IWA1(N),IWA2(N),IWA3(N),IWA4(N) LOGICAL BWA(N) C ********** C C SUBROUTINE I7DO C C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS C SUBROUTINE DETERMINES AN INCIDENCE-DEGREE ORDERING OF THE C COLUMNS OF A. C C THE INCIDENCE-DEGREE ORDERING IS DEFINED FOR THE LOOPLESS C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION. C C AT EACH STAGE OF I7DO, A COLUMN OF MAXIMAL INCIDENCE IS C CHOSEN AND ORDERED. IF JCOL IS AN UN-ORDERED COLUMN, THEN C THE INCIDENCE OF JCOL IS THE NUMBER OF ORDERED COLUMNS C ADJACENT TO JCOL IN THE GRAPH G. AMONG ALL THE COLUMNS OF C MAXIMAL INCIDENCE,I7DO CHOOSES A COLUMN OF MAXIMAL DEGREE. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, C MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW C INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. C THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. C THE COLUMN INDICES FOR ROW I ARE C C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. C C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN C OF A IS NDEG(J). C C LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE INCIDENCE-DEGREE ORDERING OF THE COLUMNS OF A. THE J-TH C COLUMN IN THIS ORDER IS LIST(J). C C MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE C OF THE LARGEST CLIQUE FOUND DURING THE ORDERING. C C IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N. C C BWA IS A LOGICAL WORK ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... N7MSRT C C FORTRAN-SUPPLIED ... MAX0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER DEG,HEAD,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU,L,MAXINC, * MAXLST,NCOMP,NUMINC,NUMLST,NUMORD,NUMWGT C C SORT THE DEGREE SEQUENCE. C CALL N7MSRT(N,N-1,NDEG,-1,IWA4,IWA1,IWA3) C C INITIALIZATION BLOCK. C C CREATE A DOUBLY-LINKED LIST TO ACCESS THE INCIDENCES OF THE C COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS. C C EACH UN-ORDERED COLUMN JCOL IS IN A LIST (THE INCIDENCE LIST) C OF COLUMNS WITH THE SAME INCIDENCE. C C IWA1(NUMINC+1) IS THE FIRST COLUMN IN THE NUMINC LIST C UNLESS IWA1(NUMINC+1) = 0. IN THIS CASE THERE ARE C NO COLUMNS IN THE NUMINC LIST. C C IWA2(JCOL) IS THE COLUMN BEFORE JCOL IN THE INCIDENCE LIST C UNLESS IWA2(JCOL) = 0. IN THIS CASE JCOL IS THE FIRST C COLUMN IN THIS INCIDENCE LIST. C C IWA3(JCOL) IS THE COLUMN AFTER JCOL IN THE INCIDENCE LIST C UNLESS IWA3(JCOL) = 0. IN THIS CASE JCOL IS THE LAST C COLUMN IN THIS INCIDENCE LIST. C C IF JCOL IS AN UN-ORDERED COLUMN, THEN LIST(JCOL) IS THE C INCIDENCE OF JCOL IN THE GRAPH. IF JCOL IS AN ORDERED COLUMN, C THEN LIST(JCOL) IS THE INCIDENCE-DEGREE ORDER OF COLUMN JCOL. C MAXINC = 0 DO 10 JP = 1, N LIST(JP) = 0 BWA(JP) = .FALSE. IWA1(JP) = 0 L = IWA4(JP) IF (JP .NE. 1) IWA2(L) = IWA4(JP-1) IF (JP .NE. N) IWA3(L) = IWA4(JP+1) 10 CONTINUE IWA1(1) = IWA4(1) L = IWA4(1) IWA2(L) = 0 L = IWA4(N) IWA3(L) = 0 C C DETERMINE THE MAXIMAL SEARCH LENGTH FOR THE LIST C OF COLUMNS OF MAXIMAL INCIDENCE. C MAXLST = 0 DO 20 IR = 1, M MAXLST = MAXLST + (IPNTR(IR+1) - IPNTR(IR))**2 20 CONTINUE MAXLST = MAXLST/N MAXCLQ = 1 C C BEGINNING OF ITERATION LOOP. C DO 140 NUMORD = 1, N C C CHOOSE A COLUMN JCOL OF MAXIMAL DEGREE AMONG THE C COLUMNS OF MAXIMAL INCIDENCE. C JP = IWA1(MAXINC+1) NUMLST = 1 NUMWGT = -1 30 CONTINUE IF (NDEG(JP) .LE. NUMWGT) GO TO 40 NUMWGT = NDEG(JP) JCOL = JP 40 CONTINUE JP = IWA3(JP) NUMLST = NUMLST + 1 IF (JP .GT. 0 .AND. NUMLST .LE. MAXLST) GO TO 30 LIST(JCOL) = NUMORD C C DELETE COLUMN JCOL FROM THE LIST OF COLUMNS OF C MAXIMAL INCIDENCE. C L = IWA2(JCOL) IF (L .EQ. 0) IWA1(MAXINC+1) = IWA3(JCOL) IF (L .GT. 0) IWA3(L) = IWA3(JCOL) L = IWA3(JCOL) IF (L .GT. 0) IWA2(L) = IWA2(JCOL) C C UPDATE THE SIZE OF THE LARGEST CLIQUE C FOUND DURING THE ORDERING. C IF (MAXINC .EQ. 0) NCOMP = 0 NCOMP = NCOMP + 1 IF (MAXINC + 1 .EQ. NCOMP) MAXCLQ = MAX0(MAXCLQ,NCOMP) C C UPDATE THE MAXIMAL INCIDENCE COUNT. C 50 CONTINUE IF (IWA1(MAXINC+1) .GT. 0) GO TO 60 MAXINC = MAXINC - 1 IF (MAXINC .GE. 0) GO TO 50 60 CONTINUE C C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. C BWA(JCOL) = .TRUE. DEG = 0 C C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND C TO NON-ZEROES IN THE MATRIX. C JPL = JPNTR(JCOL) JPU = JPNTR(JCOL+1) - 1 IF (JPU .LT. JPL) GO TO 100 DO 90 JP = JPL, JPU IR = INDROW(JP) C C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. C IPL = IPNTR(IR) IPU = IPNTR(IR+1) - 1 DO 80 IP = IPL, IPU IC = INDCOL(IP) C C ARRAY BWA MARKS COLUMNS WHICH ARE ADJACENT TO C COLUMN JCOL. ARRAY IWA4 RECORDS THE MARKED COLUMNS. C IF (BWA(IC)) GO TO 70 BWA(IC) = .TRUE. DEG = DEG + 1 IWA4(DEG) = IC 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE C C UPDATE THE POINTERS TO THE INCIDENCE LISTS. C IF (DEG .LT. 1) GO TO 130 DO 120 JP = 1, DEG IC = IWA4(JP) IF (LIST(IC) .GT. 0) GO TO 110 NUMINC = -LIST(IC) + 1 LIST(IC) = -NUMINC MAXINC = MAX0(MAXINC,NUMINC) C C DELETE COLUMN IC FROM THE NUMINC-1 LIST. C L = IWA2(IC) IF (L .EQ. 0) IWA1(NUMINC) = IWA3(IC) IF (L .GT. 0) IWA3(L) = IWA3(IC) L = IWA3(IC) IF (L .GT. 0) IWA2(L) = IWA2(IC) C C ADD COLUMN IC TO THE NUMINC LIST. C HEAD = IWA1(NUMINC+1) IWA1(NUMINC+1) = IC IWA2(IC) = 0 IWA3(IC) = HEAD IF (HEAD .GT. 0) IWA2(HEAD) = IC 110 CONTINUE C C UN-MARK COLUMN IC IN THE ARRAY BWA. C BWA(IC) = .FALSE. 120 CONTINUE 130 CONTINUE BWA(JCOL) = .FALSE. C C END OF ITERATION LOOP. C 140 CONTINUE C C INVERT THE ARRAY LIST. C DO 150 JCOL = 1, N NUMORD = LIST(JCOL) IWA1(NUMORD) = JCOL 150 CONTINUE DO 160 JP = 1, N LIST(JP) = IWA1(JP) 160 CONTINUE RETURN C C LAST CARD OF SUBROUTINE I7DO. C END INTEGER FUNCTION I7MDCN(K) C INTEGER K C C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS *** C C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. *** C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. *** C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. *** C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.) C C +++ PORT VERSION FOLLOWS... INTEGER I1MACH EXTERNAL I1MACH INTEGER MDPERM(3) DATA MDPERM(1)/2/, MDPERM(2)/4/, MDPERM(3)/1/ I7MDCN = I1MACH(MDPERM(K)) C +++ END OF PORT VERSION +++ C C +++ NON-PORT VERSION FOLLOWS... C INTEGER MDCON(3) C DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/ C I7MDCN = MDCON(K) C +++ END OF NON-PORT VERSION +++ C 999 RETURN C *** LAST CARD OF I7MDCN FOLLOWS *** END SUBROUTINE I7PNVR(N, X, Y) C C *** SET PERMUTATION VECTOR X TO INVERSE OF Y *** C INTEGER N INTEGER X(N), Y(N) C INTEGER I, J DO 10 I = 1, N J = Y(I) X(J) = I 10 CONTINUE C 999 RETURN C *** LAST LINE OF I7PNVR FOLLOWS *** END SUBROUTINE I7SHFT(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION IF K .GT. 0. C *** SHIFT X(-K),...,X(N) RIGHT CIRCULARLY ONE POSITION IF K .LT. 0. C INTEGER N, K INTEGER X(N) C INTEGER I, II, K1, NM1, T C IF (K .LT. 0) GO TO 20 IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T GO TO 999 C 20 K1 = -K IF (K1 .GE. N) GO TO 999 T = X(N) NM1 = N - K1 DO 30 II = 1, NM1 I = N - II X(I+1) = X(I) 30 CONTINUE X(K1) = T 999 RETURN C *** LAST LINE OF I7SHFT FOLLOWS *** END INTEGER FUNCTION I8SAVE(ISW,IVALUE,SET) C C IF (ISW = 1) I8SAVE RETURNS THE CURRENT ERROR NUMBER AND C SETS IT TO IVALUE IF SET = .TRUE. . C C IF (ISW = 2) I8SAVE RETURNS THE CURRENT RECOVERY SWITCH AND C SETS IT TO IVALUE IF SET = .TRUE. . C LOGICAL SET C INTEGER IPARAM(2) EQUIVALENCE (IPARAM(1),LERROR) , (IPARAM(2),LRECOV) C C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. C DATA LERROR/0/ , LRECOV/2/ C I8SAVE=IPARAM(ISW) IF (SET) IPARAM(ISW)=IVALUE C RETURN C END INTEGER FUNCTION I8TSEL(INOW) C C TO RETURN I8TSEL = THE POINTER TO THE CURRENT ENTER-BLOCK AND C SET THE CURRENT POINTER TO INOW. C C START WITH NO BACK-POINTER. C DATA IENTER/0/ C I8TSEL=IENTER IF (INOW.GE.0) IENTER=INOW C RETURN C END INTEGER FUNCTION IALLOC(NITEMS,ISIZE) C CALL I0TK01 IALLOC = ISTKGT(NITEMS,ISIZE+2) C RETURN C END INTEGER FUNCTION ICEIL(X) C C ICEIL RETURNS CEIL(X) C ICEIL = INT(X) IF (X .LE. 0.0) RETURN IF (FLOAT(ICEIL) .NE. X) ICEIL = ICEIL + 1 C RETURN END INTEGER FUNCTION IFLR(X) C C IFLR RETURNS FLR(X) C IFLR = INT(X) IF (X .GE. 0.0) RETURN IF (FLOAT(IFLR) .NE. X) IFLR = IFLR - 1 C RETURN END INTEGER FUNCTION ISTKGT(NITEMS,ITYPE) C C ALLOCATES SPACE OUT OF THE INTEGER ARRAY ISTAK (IN COMMON C BLOCK CSTAK) FOR AN ARRAY OF LENGTH NITEMS AND OF TYPE C DETERMINED BY ITYPE AS FOLLOWS C C 1 - LOGICAL C 2 - INTEGER C 3 - REAL C 4 - DOUBLE PRECISION C 5 - COMPLEX C C ON RETURN, THE ARRAY WILL OCCUPY C C STAK(ISTKGT), STAK(ISTKGT+1), ..., STAK(ISTKGT-NITEMS+1) C C WHERE STAK IS AN ARRAY OF TYPE ITYPE EQUIVALENCED TO ISTAK. C C (FOR THOSE WANTING TO MAKE MACHINE DEPENDENT MODIFICATIONS C TO SUPPORT OTHER TYPES, CODES 6,7,8,9,10,11 AND 12 HAVE C BEEN RESERVED FOR 1/4 LOGICAL, 1/2 LOGICAL, 1/4 INTEGER, C 1/2 INTEGER, QUAD PRECISION, DOUBLE COMPLEX AND QUAD C COMPLEX, RESPECTIVELY.) C C THE ALLOCATOR RESERVES THE FIRST TEN INTEGER WORDS OF THE STACK C FOR ITS OWN INTERNAL BOOK-KEEPING. THESE ARE INITIALIZED BY C THE INITIALIZING SUBPROGRAM I0TK00 UPON THE FIRST CALL C TO A SUBPROGRAM IN THE ALLOCATION PACKAGE. C C THE USE OF THE FIRST FIVE WORDS IS DESCRIBED BELOW. C C ISTAK( 1) - LOUT, THE NUMBER OF CURRENT ALLOCATIONS. C ISTAK( 2) - LNOW, THE CURRENT ACTIVE LENGTH OF THE STACK. C ISTAK( 3) - LUSED, THE MAXIMUM VALUE OF ISTAK(2) ACHIEVED. C ISTAK( 4) - LMAX, THE MAXIMUM LENGTH THE STACK. C ISTAK( 5) - LBOOK, THE NUMBER OF WORDS USED FOR BOOKEEPING. C C THE NEXT FIVE WORDS CONTAIN INTEGERS DESCRIBING THE AMOUNT C OF STORAGE ALLOCATED BY THE FORTRAN SYSTEM TO THE VARIOUS C DATA TYPES. THE UNIT OF MEASUREMENT IS ARBITRARY AND MAY C BE WORDS, BYTES OR BITS OR WHATEVER IS CONVENIENT. THE C VALUES CURRENTLY ASSUMED CORRESPOND TO AN ANS FORTRAN C ENVIRONMENT. FOR SOME MINI-COMPUTER SYSTEMS THE VALUES MAY C HAVE TO BE CHANGED (SEE I0TK00). C C ISTAK( 6) - THE NUMBER OF UNITS ALLOCATED TO LOGICAL C ISTAK( 7) - THE NUMBER OF UNITS ALLOCATED TO INTEGER C ISTAK( 8) - THE NUMBER OF UNITS ALLOCATED TO REAL C ISTAK( 9) - THE NUMBER OF UNITS ALLOCATED TO DOUBLE PRECISION C ISTAK(10) - THE NUMBER OF UNITS ALLOCATED TO COMPLEX C C ERROR STATES - C C 1 - NITEMS .LT. 0 C 2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6 C 3 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN C 4 - STACK OVERFLOW C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) INTEGER ISIZE(5) C LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),LOUT) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),ISIZE(1)) C DATA INIT/.TRUE./ C IF (INIT) CALL I0TK00(INIT,500,4) C C/6S C IF (NITEMS.LT.0) CALL SETERR(20HISTKGT - NITEMS.LT.0,20,1,2) C/7S IF (NITEMS.LT.0) CALL SETERR('ISTKGT - NITEMS.LT.0',20,1,2) C/ C C/6S C IF (ITYPE.LE.0 .OR. ITYPE.GE.6) CALL SETERR C 1 (33HISTKGT - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2) C/7S IF (ITYPE.LE.0 .OR. ITYPE.GE.6) CALL SETERR 1 ('ISTKGT - ITYPE.LE.0.OR.ITYPE.GE.6',33,2,2) C/ C C/6S C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR C 1 (47HISTKGT - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN, C 2 47,3,2) C/7S IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR 1 ('ISTKGT - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN', 2 47,3,2) C/ C ISTKGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2 I = ( (ISTKGT-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3 C C STACK OVERFLOW IS AN UNRECOVERABLE ERROR. C C/6S C IF (I.GT.LMAX) CALL SETERR(69HISTKGT - STACK TOO SHORT. ENLARGE IT C 1 AND CALL ISTKIN IN MAIN PROGRAM.,69,4,2) C/7S IF (I.GT.LMAX) CALL SETERR('ISTKGT - STACK TOO SHORT. ENLARGE IT A *ND CALL ISTKIN IN MAIN PROGRAM.',69,4,2) C/ C C ISTAK(I-1) CONTAINS THE TYPE FOR THIS ALLOCATION. C ISTAK(I ) CONTAINS A POINTER TO THE END OF THE PREVIOUS C ALLOCATION. C ISTAK(I-1) = ITYPE ISTAK(I ) = LNOW LOUT = LOUT+1 LNOW = I LUSED = MAX0(LUSED,LNOW) C RETURN C END SUBROUTINE ISTKIN(NITEMS,ITYPE) C C INITIALIZES THE STACK ALLOCATOR, SETTING THE LENGTH OF THE STACK. C C ERROR STATES - C C 1 - NITEMS .LE. 0 C 2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6 C LOGICAL INIT C DATA INIT/.TRUE./ C C/6S C IF (NITEMS.LE.0) CALL SETERR(20HISTKIN - NITEMS.LE.0,20,1,2) C/7S IF (NITEMS.LE.0) CALL SETERR('ISTKIN - NITEMS.LE.0',20,1,2) C/ C C/6S C IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR C 1 (33HISTKIN - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2) C/7S IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR 1 ('ISTKIN - ITYPE.LE.0.OR.ITYPE.GE.6',33,2,2) C/ C IF (INIT) CALL I0TK00(INIT,NITEMS,ITYPE) C RETURN C END INTEGER FUNCTION ISTKMD(NITEMS) C C CHANGES THE LENGTH OF THE FRAME AT THE TOP OF THE STACK C TO NITEMS. C C ERROR STATES - C C 1 - LNOW OVERWRITTEN C 2 - ISTAK(LNOWO-1) OVERWRITTEN C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(2),LNOW) C LNOWO = LNOW CALL ISTKRL(1) C ITYPE = ISTAK(LNOWO-1) C C/6S C IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR C 1 (35HISTKMD - ISTAK(LNOWO-1) OVERWRITTEN,35,1,2) C/7S IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR 1 ('ISTKMD - ISTAK(LNOWO-1) OVERWRITTEN',35,1,2) C/ C ISTKMD = ISTKGT(NITEMS,ITYPE) C RETURN C END INTEGER FUNCTION ISTKQU(ITYPE) C C RETURNS THE NUMBER OF ITEMS OF TYPE ITYPE THAT REMAIN C TO BE ALLOCATED IN ONE REQUEST. C C ERROR STATES - C C 1 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN C 2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6 C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) INTEGER ISIZE(5) C LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),ISIZE(1)) C DATA INIT/.TRUE./ C IF (INIT) CALL I0TK00(INIT,500,4) C C/6S C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR C 1 (47HISTKQU - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN, C 2 47,1,2) C/7S IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR 1 ('ISTKQU - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN', 2 47,1,2) C/ C C/6S C IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR C 1 (33HISTKQU - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2) C/7S IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR 1 ('ISTKQU - ITYPE.LE.0.OR.ITYPE.GE.6',33,2,2) C/ C ISTKQU = MAX0( ((LMAX-2)*ISIZE(2))/ISIZE(ITYPE) 1 - (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) 2 - 1, 0 ) C RETURN C END SUBROUTINE ISTKRL(NUMBER) C C DE-ALLOCATES THE LAST (NUMBER) ALLOCATIONS MADE IN THE STACK C BY ISTKGT. C C ERROR STATES - C C 1 - NUMBER .LT. 0 C 2 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN C 3 - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION C 4 - THE POINTER AT ISTAK(LNOW) OVERWRITTEN C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),LOUT) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) C DATA INIT/.TRUE./ C IF (INIT) CALL I0TK00(INIT,500,4) C C/6S C IF (NUMBER.LT.0) CALL SETERR(20HISTKRL - NUMBER.LT.0,20,1,2) C/7S IF (NUMBER.LT.0) CALL SETERR('ISTKRL - NUMBER.LT.0',20,1,2) C/ C C/6S C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR C 1 (47HISTKRL - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN, C 2 47,2,2) C/7S IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR 1 ('ISTKRL - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN', 2 47,2,2) C/ C IN = NUMBER 10 IF (IN.EQ.0) RETURN C C/6S C IF (LNOW.LE.LBOOK) CALL SETERR C 1 (55HISTKRL - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION, C 2 55,3,2) C/7S IF (LNOW.LE.LBOOK) CALL SETERR 1 ('ISTKRL - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION', 2 55,3,2) C/ C C CHECK TO MAKE SURE THE BACK POINTERS ARE MONOTONE. C C/6S C IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) CALL SETERR C 1 (47HISTKRL - THE POINTER AT ISTAK(LNOW) OVERWRITTEN, C 2 47,4,2) C/7S IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) CALL SETERR 1 ('ISTKRL - THE POINTER AT ISTAK(LNOW) OVERWRITTEN', 2 47,4,2) C/ C LOUT = LOUT-1 LNOW = ISTAK(LNOW) IN = IN-1 GO TO 10 C END INTEGER FUNCTION ISTKST(NFACT) C C RETURNS CONTROL INFORMATION AS FOLLOWS C C NFACT ITEM RETURNED C C 1 LOUT, THE NUMBER OF CURRENT ALLOCATIONS C 2 LNOW, THE CURRENT ACTIVE LENGTH C 3 LUSED, THE MAXIMUM USED C 4 LMAX, THE MAXIMUM ALLOWED C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) INTEGER ISTATS(4) LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),ISTATS(1)) C DATA INIT/.TRUE./ C IF (INIT) CALL I0TK00(INIT,500,4) C C/6S C IF (NFACT.LE.0.OR.NFACT.GE.5) CALL SETERR C 1 (33HISTKST - NFACT.LE.0.OR.NFACT.GE.5,33,1,2) C/7S IF (NFACT.LE.0.OR.NFACT.GE.5) CALL SETERR 1 ('ISTKST - NFACT.LE.0.OR.NFACT.GE.5',33,1,2) C/ C ISTKST = ISTATS(NFACT) C RETURN C END SUBROUTINE ITSUM(D, G, IV, LIV, LV, P, V, X) C C *** PRINT ITERATION SUMMARY FOR ***SOL (VERSION 2.3) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P INTEGER IV(LIV) REAL D(P), G(P), V(LV), X(P) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER ALG, I, IV1, M, NF, NG, OL, PU C/6S C REAL MODEL1(6), MODEL2(6) C/7S CHARACTER*4 MODEL1(6), MODEL2(6) C/ REAL NRELDF, OLDF, PRELDF, RELDF, ZERO C C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER ALGSAV, DSTNRM, F, FDIF, F0, NEEDHD, NFCALL, NFCOV, NGCOV, 1 NGCALL, NITER, NREDUC, OUTLEV, PREDUC, PRNTIT, PRUNIT, 2 RELDX, SOLPRT, STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA ALGSAV/51/, NEEDHD/36/, NFCALL/6/, NFCOV/52/, NGCALL/30/, C 1 NGCOV/53/, NITER/31/, OUTLEV/19/, PRNTIT/39/, PRUNIT/21/, C 2 SOLPRT/22/, STATPR/23/, SUSED/64/, X0PRT/24/ C/7 PARAMETER (ALGSAV=51, NEEDHD=36, NFCALL=6, NFCOV=52, NGCALL=30, 1 NGCOV=53, NITER=31, OUTLEV=19, PRNTIT=39, PRUNIT=21, 2 SOLPRT=22, STATPR=23, SUSED=64, X0PRT=24) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, PREDUC/7/, C 1 RELDX/17/, STPPAR/5/ C/7 PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, PREDUC=7, 1 RELDX=17, STPPAR=5) C/ C C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C/6S C DATA MODEL1(1)/4H /, MODEL1(2)/4H /, MODEL1(3)/4H /, C 1 MODEL1(4)/4H /, MODEL1(5)/4H G /, MODEL1(6)/4H S /, C 2 MODEL2(1)/4H G /, MODEL2(2)/4H S /, MODEL2(3)/4HG-S /, C 3 MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/ C/7S DATA MODEL1/' ',' ',' ',' ',' G ',' S '/, 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/ C/ C C------------------------------- BODY -------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IV1 = IV(1) IF (IV1 .GT. 62) IV1 = IV1 - 51 OL = IV(OUTLEV) ALG = MOD(IV(ALGSAV)-1,2) + 1 IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 370 IF (IV1 .GE. 12) GO TO 120 IF (IV1 .EQ. 2 .AND. IV(NITER) .EQ. 0) GO TO 390 IF (OL .EQ. 0) GO TO 120 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 120 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999 10 NF = IV(NFCALL) - IABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = AMAX1( ABS(V(F0)), ABS(V(F))) IF (OLDF .LE. ZERO) GO TO 20 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 20 IF (OL .GT. 0) GO TO 60 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,30) 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,40) 40 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR) IV(NEEDHD) = 0 IF (ALG .EQ. 2) GO TO 50 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR) GO TO 120 C 50 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 V(STPPAR) GO TO 120 C C *** PRINT LONG SUMMARY LINE *** C 60 IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,70) 70 FORMAT(/11H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR,2X,6HD*STEP,2X,7HNPRELDF) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,80) 80 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR,3X,6HD*STEP,3X,7HNPRELDF) IV(NEEDHD) = 0 NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF IF (ALG .EQ. 2) GO TO 90 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR), V(DSTNRM), NRELDF GO TO 120 C 90 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, 1 V(RELDX), V(STPPAR), V(DSTNRM), NRELDF 100 FORMAT(I6,I5,E10.3,2E9.2,E8.1,A3,A4,2E8.1,E9.2) 110 FORMAT(I6,I5,E11.3,2E10.2,3E9.1,E10.2) C 120 IF (IV1 .LE. 2) GO TO 999 I = IV(STATPR) IF (I .EQ. (-1)) GO TO 460 IF (I + IV1 .LT. 0) GO TO 460 GO TO (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, 1 330, 350, 500), IV1 C 130 WRITE(PU,140) 140 FORMAT(/26H ***** X-CONVERGENCE *****) GO TO 430 C 150 WRITE(PU,160) 160 FORMAT(/42H ***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 170 WRITE(PU,180) 180 FORMAT(/49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 190 WRITE(PU,200) 200 FORMAT(/42H ***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 430 C 210 WRITE(PU,220) 220 FORMAT(/33H ***** SINGULAR CONVERGENCE *****) GO TO 430 C 230 WRITE(PU,240) 240 FORMAT(/30H ***** FALSE CONVERGENCE *****) GO TO 430 C 250 WRITE(PU,260) 260 FORMAT(/38H ***** FUNCTION EVALUATION LIMIT *****) GO TO 430 C 270 WRITE(PU,280) 280 FORMAT(/28H ***** ITERATION LIMIT *****) GO TO 430 C 290 WRITE(PU,300) 300 FORMAT(/18H ***** STOPX *****) GO TO 430 C 310 WRITE(PU,320) 320 FORMAT(/44H ***** INITIAL F(X) CANNOT BE COMPUTED *****) C GO TO 390 C 330 WRITE(PU,340) 340 FORMAT(/37H ***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 350 WRITE(PU,360) 360 FORMAT(/43H ***** GRADIENT COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 460 GO TO 390 C 370 WRITE(PU,380) IV(1) 380 FORMAT(/14H ***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON ITSUM *** C 390 IF (IV(X0PRT) .NE. 0) WRITE(PU,400) (I, X(I), D(I), I = 1, P) 400 FORMAT(/23H I INITIAL X(I),8X,4HD(I)//(1X,I5,E17.6,E14.3)) C *** THE FOLLOWING ARE TO AVOID UNDEFINED VARIABLES WHEN THE C *** FUNCTION EVALUATION LIMIT IS 1... V(DSTNRM) = ZERO V(FDIF) = ZERO V(NREDUC) = ZERO V(PREDUC) = ZERO V(RELDX) = ZERO IF (IV1 .GE. 12) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0 .AND. ALG .EQ. 1) WRITE(PU,30) IF (OL .LT. 0 .AND. ALG .EQ. 2) WRITE(PU,40) IF (OL .GT. 0 .AND. ALG .EQ. 1) WRITE(PU,70) IF (OL .GT. 0 .AND. ALG .EQ. 2) WRITE(PU,80) IF (ALG .EQ. 1) WRITE(PU,410) IV(NFCALL), V(F) IF (ALG .EQ. 2) WRITE(PU,420) IV(NFCALL), V(F) 410 FORMAT(/6H 0,I5,E10.3) 420 FORMAT(/6H 0,I5,E11.3) GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 430 IV(NEEDHD) = 1 IF (IV(STATPR) .LE. 0) GO TO 460 OLDF = AMAX1( ABS(V(F0)), ABS(V(F))) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 440 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 440 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(PU,450) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 450 FORMAT(/9H FUNCTION,E17.6,8H RELDX,E17.3/12H FUNC. EVALS, 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,E16.3,6X,7HNPRELDF,E15.3) C 460 IF (IV(SOLPRT) .EQ. 0) GO TO 999 IV(NEEDHD) = 1 IF (IV(ALGSAV) .GT. 2) GO TO 999 WRITE(PU,470) 470 FORMAT(/22H I FINAL X(I),8X,4HD(I),10X,4HG(I)/) DO 480 I = 1, P 480 WRITE(PU,490) I, X(I), D(I), G(I) 490 FORMAT(1X,I5,E16.6,2E14.3) GO TO 999 C 500 WRITE(PU,510) 510 FORMAT(/24H INCONSISTENT DIMENSIONS) 999 RETURN C *** LAST CARD OF ITSUM FOLLOWS *** END SUBROUTINE IVSET(ALG, IV, LIV, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER LIV, LV INTEGER ALG, IV(LIV) REAL V(LV) C INTEGER I7MDCN EXTERNAL I7MDCN, V7DFL C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS. C V7DFL.... PROVIDES DEFAULT VALUES TO V. C INTEGER ALG1, MIV, MV INTEGER MINIV(4), MINV(4) C C *** SUBSCRIPTS FOR IV *** C INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH, 1 INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL, 2 MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT, 3 PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR, 4 VNEED, VSAVE, X0PRT C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA ALGSAV/51/, COVPRT/14/, COVREQ/15/, DRADPR/101/, DTYPE/16/, C 1 HC/71/, IERR/75/, INITH/25/, INITS/25/, IPIVOT/76/, C 2 IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/, MXFCAL/17/, C 3 MXITER/18/, NFCOV/52/, NGCOV/53/, NVDFLT/50/, NVSAVE/9/, C 4 OUTLEV/19/, PARPRT/20/, PARSAV/49/, PERM/58/, PRUNIT/21/, C 5 QRTYP/80/, RDREQ/57/, RMAT/78/, SOLPRT/22/, STATPR/23/, C 6 VNEED/4/, VSAVE/60/, X0PRT/24/ C/7 PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16, 1 HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76, 2 IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17, 3 MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9, 4 OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21, 5 QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23, 6 VNEED=4, VSAVE=60, X0PRT=24) C/ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/, 1 MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/ C C------------------------------- BODY -------------------------------- C IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1) IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40 MIV = MINIV(ALG) IF (LIV .LT. MIV) GO TO 20 MV = MINV(ALG) IF (LV .LT. MV) GO TO 30 ALG1 = MOD(ALG-1,2) + 1 CALL V7DFL(ALG1, LV, V) IV(1) = 12 IF (ALG .GT. 2) IV(DRADPR) = 1 IV(IVNEED) = 0 IV(LASTIV) = MIV IV(LASTV) = MV IV(LMAT) = MV + 1 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PERM) = MIV + 1 IV(SOLPRT) = 1 IV(STATPR) = 1 IV(VNEED) = 0 IV(X0PRT) = 1 C IF (ALG1 .GE. 2) GO TO 10 C C *** REGRESSION VALUES C IV(COVPRT) = 3 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(HC) = 0 IV(IERR) = 0 IV(INITS) = 0 IV(IPIVOT) = 0 IV(NVDFLT) = 32 IV(VSAVE) = 58 IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3 IV(PARSAV) = IV(VSAVE) + NVSAVE IV(QRTYP) = 1 IV(RDREQ) = 3 IV(RMAT) = 0 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 IV(DTYPE) = 0 IV(INITH) = 1 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(NVDFLT) = 25 IV(PARSAV) = 47 IF (ALG .GT. 2) IV(PARSAV) = 61 GO TO 999 C 20 IV(1) = 15 GO TO 999 C 30 IV(1) = 16 GO TO 999 C 40 IV(1) = 67 C 999 RETURN C *** LAST CARD OF IVSET FOLLOWS *** END SUBROUTINE L5STP(NPTS, MESH, FN, QK, DELK, M, N, P, Q) INTEGER NPTS INTEGER M, N REAL MESH(NPTS), FN(NPTS), QK(NPTS), DELK, P(1), Q(1) COMMON /CSTAK/ DSTAK DOUBLE PRECISION DSTAK(500) INTEGER APTR, XPTR, ISTKGT, ISTAK(1000) INTEGER BC, BX, C, G, IW, LIW, LW, MM, NN, W REAL WS(500) EQUIVALENCE (DSTAK(1), ISTAK(1)) EQUIVALENCE (DSTAK(1), WS(1)) C THIS ROUTINE ALLOCATES STORAGE SO THAT C L9STP CAN DEFINE THE LINEAR PROGRAMMING SUBPROBLEM OF C THE DIFFERENTIAL CORRECTION ALGORITHM AND CALL A GENERAL C PURPOSE LINEAR PROGRAMMING PACKAGE. C INPUT... C NPTS - THE NUMBER OF MESH POINTS. C MESH - THE ARRAY OF MESH POINTS. C FN - THE ARRAY OF FUNCTION VALUES. C QK - THE ARRAY OF CURRENT DENOMINATOR VALUES. C DELK - THE CURRENT MINIMAX ERROR. C M - THE DEGREE OF THE NUMERATOR POLYNOMIAL. C N - THE DEGREE OF THE DENOMINATOR POLYNOMIAL. C P - THE CURRENT NUMERATOR POLYNOMIAL. C Q - THE CURRENT DENOMINATOR POLYNOMIAL. C OUTPUT... C P - THE ARRAY OF COEFFICIENTS FOR THE NUMERATOR POLYNOMIAL. C Q - THE ARRAY OF COEFFICIENTS FOR THE DENOMINATOR POLYNOMIAL. C ERROR STATES (ASTERISK INDICATES FATAL)... C 1* - INVALID DEGREE C 2* - TOO FEW MESH POINTS C 3* - NONPOSITIVE DELK C 4 - NO IMPROVEMENT IN THE LP SUBPROBLEM C C *** BODY *** C CALL ENTER(1) C/6S C IF (M .LT. 0 .OR. N .LT. 0) CALL SETERR( C 1 23H L5STP - INVALID DEGREE, 23, 1, 2) C IF (NPTS .LT. M+N+2) CALL SETERR(28H L5STP - TOO FEW MESH POINTS, C 1 28, 2, 2) C/7S IF (M .LT. 0 .OR. N .LT. 0) CALL SETERR( 1 ' L5STP - INVALID DEGREE', 23, 1, 2) IF (NPTS .LT. M+N+2) CALL SETERR(' L5STP - TOO FEW MESH POINTS', 1 28, 2, 2) C/ MM = 2 * NPTS NN = M + N + 3 LIW = MM + NN + 7 LW = NN*(3*NN+17)/2 + MM + 2 G = ISTKGT(NN, 3) C = ISTKGT(NN*MM, 3) BC = ISTKGT(2*MM, 3) BX = ISTKGT(2*NN, 3) W = ISTKGT(LW, 3) IW = ISTKGT(LIW, 2) APTR = ISTKGT(3*NPTS+1, 3) XPTR = ISTKGT(NN, 3) CALL L9STP(NPTS, MESH, FN, QK, DELK, M, N, P, Q, WS(APTR), 1 WS(BC), WS(BX), WS(C), WS(G), ISTAK(IW), LIW, LW, 2 MM, NN, WS(W), WS(XPTR)) CALL LEAVE RETURN C *** LAST LINE OF L5STP FOLLOWS *** END SUBROUTINE L7ITV(N, X, L, Y) C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 REAL XI, ZERO C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST CARD OF L7ITV FOLLOWS *** END SUBROUTINE L7IVM(N, X, L, Y) C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) REAL D7TPR EXTERNAL D7TPR INTEGER I, J, K REAL T, ZERO C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C DO 10 K = 1, N IF (Y(K) .NE. ZERO) GO TO 20 X(K) = ZERO 10 CONTINUE GO TO 999 20 J = K*(K+1)/2 X(K) = Y(K) / L(J) IF (K .GE. N) GO TO 999 K = K + 1 DO 30 I = K, N T = D7TPR(I-1, L(J+1), X) J = J + I X(I) = (Y(I) - T)/L(J) 30 CONTINUE 999 RETURN C *** LAST CARD OF L7IVM FOLLOWS *** END SUBROUTINE L7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT, 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V, 2 W, WLM, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER IERR, KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) REAL B(2,P), D(P), G(P), LMAT(1), QTR(P), RMAT(1), 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(1), 2 X0(P), X(P) C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4) C REAL D7TPR EXTERNAL D7MLP, D7TPR, L7MST, L7TVM, Q7RSH, S7BQN, 1 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP C C *** LOCAL VARIABLES *** C INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11 REAL DS0, NRED, PRED, RAD REAL ONE, ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C C/6 C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/, C 1 RADIUS/8/ C/7 PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) C/ DATA ONE/1.E+0/, ZERO/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C P1 = PC IF (KA .LT. 0) GO TO 10 NRED = V(NREDUC) DS0 = V(DST0) GO TO 20 10 P0 = 0 KA = -1 C 20 KINIT = -1 IF (P0 .EQ. P1) KINIT = KA CALL V7CPY(P, X, X0) CALL V7CPY(P, TD, D) C *** USE STEP(1,3) AS TEMP. COPY OF QTR *** CALL V7CPY(P, STEP(1,3), QTR) CALL V7IPR(P, IPIV, TD) PRED = ZERO RAD = V(RADIUS) KB = -1 V(DSTNRM) = ZERO IF (P1 .GT. 0) GO TO 30 NRED = ZERO DS0 = ZERO CALL V7SCP(P, STEP, ZERO) GO TO 90 C 30 CALL V7VMP(P, TG, G, D, -1) CALL V7IPR(P, IPIV, TG) P10 = P1 40 K = KINIT KINIT = -1 V(RADIUS) = RAD - V(DSTNRM) CALL V7VMP(P1, TG, TG, TD, 1) DO 50 I = 1, P1 50 IPIV1(I) = I K0 = MAX0(0, K) CALL L7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP, 1 V, WLM) CALL V7VMP(P1, TG, TG, TD, -1) P0 = P1 IF (KA .GE. 0) GO TO 60 NRED = V(NREDUC) DS0 = V(DST0) C 60 KA = K V(RADIUS) = RAD L = P1 + 5 IF (K .LE. K0) CALL D7MLP(P1, LMAT, TD, RMAT, -1) IF (K .GT. K0) CALL D7MLP(P1, LMAT, TD, WLM(L), -1) CALL S7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT, 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0) PRED = PRED + V(PREDUC) IF (NS .EQ. 0) GO TO 80 P0 = 0 C C *** UPDATE RMAT AND QTR *** C P11 = P1 + 1 L = P10 + P11 DO 70 K = P11, P10 J = L - K I = IPIV2(J) IF (I .LT. J) CALL Q7RSH(I, J, .TRUE., QTR, RMAT, W) 70 CONTINUE C 80 IF (KB .GT. 0) GO TO 90 C C *** UPDATE LOCAL COPY OF QTR *** C CALL V7VMP(P10, W, STEP(1,2), TD, -1) CALL L7TVM(P10, W, LMAT, W) CALL V2AXY(P10, STEP(1,3), ONE, W, QTR) GO TO 40 C 90 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = D7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF L7MSB FOLLOWS *** END SUBROUTINE L7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, KA, P INTEGER IPIVOT(P) REAL D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR Q7RGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR Q7RGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C L7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C D7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C L7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C L7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C V7CPY - COPIES ONE VECTOR TO ANOTHER. C V2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 REAL A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** REAL DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, 1 TTOL, ZERO REAL BIG C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, L7SVN, R7MDC, V2NRM EXTERNAL D7TPR, L7ITV, L7IVM, L7SVN, R7MDC, V7CPY, V2NRM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR C/6 C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/, C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/, C 2 RAD0/9/, STPPAR/5/ C/7 PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4, 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8, 2 RAD0=9, STPPAR=5) C/ C C/6 C DATA DFAC/256.E+0/, EIGHT/8.E+0/, HALF/0.5E+0/, NEGONE/-1.E+0/, C 1 ONE/1.E+0/, P001/1.E-3/, THREE/3.E+0/, TTOL/2.5E+0/, C 2 ZERO/0.E+0/ C/7 PARAMETER (DFAC=256.E+0, EIGHT=8.E+0, HALF=0.5E+0, NEGONE=-1.E+0, 1 ONE=1.E+0, P001=1.E-3, THREE=3.E+0, TTOL=2.5E+0, 2 ZERO=0.E+0) SAVE BIG C/ DATA BIG/0.E+0/ C C *** BODY *** C C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK, C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J) C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0), C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY. LK0 = P + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 RMAT0 = DSTSAV C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER C *** WORK ON THESE COPIES. RMAT = RMAT0 + 1 PP1O2 = P * (P + 1) / 2 RES0 = PP1O2 + RMAT0 RES = RES0 + 1 RAD = V(RADIUS) IF (RAD .GT. ZERO) 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2) IF (BIG .LE. ZERO) BIG = R7MDC(6) PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION. DTOL = ONE/DFAC DFACSQ = DFAC*DFAC C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO LK = ZERO UK = ZERO KALIM = KA + 12 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 V(NREDUC) = HALF* D7TPR(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 T = L7SVN(P, R, STEP, W(RES)) IF (T .GE. ONE) GO TO 30 IF ( V2NRM(P, QTR) .GE. BIG*T) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING L7ITV AND L7IVM. 30 CALL L7ITV(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = V2NRM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL L7IVM(P, STEP, R, STEP) T = ONE / V2NRM(P, STEP) W(PHIPIN) = (T/RAD)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = V2NRM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. C ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = AMIN1(UK, AMAX1(ALPHAK, LK)) C C C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES *** C 110 KA = KA + 1 CALL V7CPY(PP1O2, W(RMAT), R) CALL V7CPY(P, W(RES), QTR) C C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. *** C IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * AMAX1(P001, SQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK SQRTAK = SQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. ABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P SI = STEP(I1-1) IF (SI .EQ. ZERO) GO TO 260 L = I1*(I1+1)/2 + RMAT0 WL = W(L) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF ( ABS(SI) .GT. ABS(WL)) GO TO 220 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL L7ITV(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = V2NRM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - D7TPR(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL L7IVM(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / SQRT(W(I)) T = ONE / V2NRM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = AMAX1(LK, ALPHAK) ALPHAK = LK GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = ABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** BIGGER RADIUS *** 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T LK = ZERO IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = AMIN1( D7TPR(P,STEP,G), ZERO) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C 999 RETURN C C *** LAST CARD OF L7MST FOLLOWS *** END SUBROUTINE L7NVR(N, LIN, L) C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C *** PARAMETERS *** C INTEGER N REAL L(1), LIN(1) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 REAL ONE, T, ZERO C/6 C DATA ONE/1.E+0/, ZERO/0.E+0/ C/7 PARAMETER (ONE=1.E+0, ZERO=0.E+0) C/ C C *** BODY *** C NP1 = N + 1 J0 = N*(NP1)/2 DO 30 II = 1, N I = NP1 - II LIN(J0) = ONE/L(J0) IF (I .LE. 1) GO TO 999 J1 = J0 IM1 = I - 1 DO 20 JJ = 1, IM1 T = ZERO J0 = J1 K0 = J1 - JJ DO 10 K = 1, JJ T = T - L(K0)*LIN(J0) J0 = J0 - 1 K0 = K0 + K - I 10 CONTINUE LIN(J0) = T/L(K0) 20 CONTINUE J0 = J0 - 1 30 CONTINUE 999 RETURN C *** LAST CARD OF L7NVR FOLLOWS *** END SUBROUTINE L7SQR(N, A, L) C C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE C *** SAME STORAGE. C C *** PARAMETERS *** C INTEGER N REAL A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1 REAL T C NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II IP1 = I + 1 I0 = I0 - I J0 = I*(I+1)/2 DO 20 JJ = 1, I J = IP1 - JJ J0 = J0 - J T = 0.0E0 DO 10 K = 1, J IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE IJ = I0 + J A(IJ) = T 20 CONTINUE 30 CONTINUE 999 RETURN END SUBROUTINE L7SRT(N1, N, L, A, IRC) C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C *** PARAMETERS *** C INTEGER N1, N, IRC REAL L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K REAL T, TD, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C C *** BODY *** C I0 = N1 * (N1 - 1) / 2 DO 50 I = N1, N TD = ZERO IF (I .EQ. 1) GO TO 40 J0 = 0 IM1 = I - 1 DO 30 J = 1, IM1 T = ZERO IF (J .EQ. 1) GO TO 20 JM1 = J - 1 DO 10 K = 1, JM1 IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE 20 IJ = I0 + J J0 = J0 + J T = (A(IJ) - T) / L(J0) L(IJ) = T TD = TD + T*T 30 CONTINUE 40 I0 = I0 + I T = A(I0) - TD IF (T .LE. ZERO) GO TO 60 L(I0) = SQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST CARD OF L7SRT *** END REAL FUNCTION L7SVN(P, L, X, Y) C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF L7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF L7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF L7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF L7SVN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO L7SVN RETURNS). C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C L7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1 REAL B, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C REAL HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL D7TPR, V2NRM, V2AXY C C/6 C DATA HALF/0.5E+0/, ONE/1.E+0/, R9973/9973.E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ONE=1.E+0, R9973=9973.E+0, ZERO=0.E+0) C/ C C *** BODY *** C IX = 2 PM1 = P - 1 C C *** FIRST CHECK WHETHER TO RETURN L7SVN = 0 AND INITIALIZE X *** C II = 0 J0 = P*PM1/2 JJ = J0 + P IF (L(JJ) .EQ. ZERO) GO TO 110 IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = B / L(JJ) X(P) = XPLUS IF (P .LE. 1) GO TO 60 DO 10 I = 1, PM1 II = II + I IF (L(II) .EQ. ZERO) GO TO 110 JI = J0 + I X(I) = XPLUS * L(JI) 10 CONTINUE C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 50 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = ABS(XPLUS) SMINUS = ABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .GT. 0) CALL V2AXY(JM1, X, XPLUS, L(J0+1), X) 50 CONTINUE C C *** NORMALIZE X *** C 60 T = ONE/ V2NRM(P, X) DO 70 I = 1, P 70 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN L7SVN = 1/TWONORM(Y) *** C DO 100 J = 1, P JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J T = ZERO IF (JM1 .GT. 0) T = D7TPR(JM1, L(J0+1), Y) Y(J) = (X(J) - T) / L(JJ) 100 CONTINUE C L7SVN = ONE/ V2NRM(P, Y) GO TO 999 C 110 L7SVN = ZERO 999 RETURN C *** LAST CARD OF L7SVN FOLLOWS *** END REAL FUNCTION L7SVX(P, L, X, Y) C C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF L7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS C APPROXIMATION MAY BE CRUDE. C Y (OUT) IF L7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND- C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X C OVER-WRITES Y. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1 REAL B, BLJI, SMINUS, SPLUS, T, YI C C *** CONSTANTS *** C REAL HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL D7TPR, V2NRM, V2AXY C C/6 C DATA HALF/0.5E+0/, ONE/1.E+0/, R9973/9973.E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ONE=1.E+0, R9973=9973.E+0, ZERO=0.E+0) C/ C C *** BODY *** C IX = 2 PPLUS1 = P + 1 PM1 = P - 1 C C *** FIRST INITIALIZE X TO PARTIAL SUMS *** C J0 = P*PM1/2 JJ = J0 + P IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) X(P) = B * L(JJ) IF (P .LE. 1) GO TO 40 DO 10 I = 1, PM1 JI = J0 + I X(I) = B * L(JI) 10 CONTINUE C C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 30 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) JM1 = J - 1 J0 = J*JM1/2 SPLUS = ZERO SMINUS = ZERO DO 20 I = 1, J JI = J0 + I BLJI = B * L(JI) SPLUS = SPLUS + ABS(BLJI + X(I)) SMINUS = SMINUS + ABS(BLJI - X(I)) 20 CONTINUE IF (SMINUS .GT. SPLUS) B = -B X(J) = ZERO C *** UPDATE PARTIAL SUMS *** CALL V2AXY(J, X, B, L(J0+1), X) 30 CONTINUE C C *** NORMALIZE X *** C 40 T = V2NRM(P, X) IF (T .LE. ZERO) GO TO 80 T = ONE / T DO 50 I = 1, P 50 X(I) = T*X(I) C C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) *** C DO 60 JJJ = 1, P J = PPLUS1 - JJJ JI = J*(J-1)/2 + 1 Y(J) = D7TPR(J, L(JI), X) 60 CONTINUE C C *** NORMALIZE Y AND SET X = (L**T)*Y *** C T = ONE / V2NRM(P, Y) JI = 1 DO 70 I = 1, P YI = T * Y(I) X(I) = ZERO CALL V2AXY(I, X, YI, L(JI), X) JI = JI + I 70 CONTINUE L7SVX = V2NRM(P, X) GO TO 999 C 80 L7SVX = ZERO C 999 RETURN C *** LAST CARD OF L7SVX FOLLOWS *** END SUBROUTINE L7TSQ(N, A, L) C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C INTEGER N REAL A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C INTEGER I, II, IIM1, I1, J, K, M REAL LII, LJ C II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C 999 RETURN C *** LAST CARD OF L7TSQ FOLLOWS *** END SUBROUTINE L7TVM(N, X, L, Y) C C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY C *** OCCUPY THE SAME STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, IJ, I0, J REAL YI, ZERO C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C I0 = 0 DO 20 I = 1, N YI = Y(I) X(I) = ZERO DO 10 J = 1, I IJ = I0 + J X(J) = X(J) + YI*L(IJ) 10 CONTINUE I0 = I0 + I 20 CONTINUE 999 RETURN C *** LAST CARD OF L7TVM FOLLOWS *** END SUBROUTINE L7UPD(BETA, GAMMA, L, LAMBDA, LPLUS, N, W, Z) C C *** COMPUTE LPLUS = SECANT UPDATE OF L *** C C *** PARAMETER DECLARATIONS *** C INTEGER N REAL BETA(N), GAMMA(N), L(1), LAMBDA(N), LPLUS(1), 1 W(N), Z(N) C DIMENSION L(N*(N+1)/2), LPLUS(N*(N+1)/2) C C-------------------------- PARAMETER USAGE -------------------------- C C BETA = SCRATCH VECTOR. C GAMMA = SCRATCH VECTOR. C L (INPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE. C LAMBDA = SCRATCH VECTOR. C LPLUS (OUTPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE, WHICH MAY C OCCUPY THE SAME STORAGE AS L. C N (INPUT) LENGTH OF VECTOR PARAMETERS AND ORDER OF MATRICES. C W (INPUT, DESTROYED ON OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 C CORRECTION TO L. C Z (INPUT, DESTROYED ON OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 C CORRECTION TO L. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE UPDATES THE CHOLESKY FACTOR L OF A SYMMETRIC C POSITIVE DEFINITE MATRIX TO WHICH A SECANT UPDATE IS BEING C APPLIED -- IT COMPUTES A CHOLESKY FACTOR LPLUS OF C L * (I + Z*W**T) * (I + W*Z**T) * L**T. IT IS ASSUMED THAT W C AND Z HAVE BEEN CHOSEN SO THAT THE UPDATED MATRIX IS STRICTLY C POSITIVE DEFINITE. C C *** ALGORITHM NOTES *** C C THIS CODE USES RECURRENCE 3 OF REF. 1 (WITH D(J) = 1 FOR ALL J) C TO COMPUTE LPLUS OF THE FORM L * (I + Z*W**T) * Q, WHERE Q C IS AN ORTHOGONAL MATRIX THAT MAKES THE RESULT LOWER TRIANGULAR. C LPLUS MAY HAVE SOME NEGATIVE DIAGONAL ELEMENTS. C C *** REFERENCES *** C C 1. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON- C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811. C C *** GENERAL *** C C CODED BY DAVID M. GAY (FALL 1979). C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I, IJ, J, JJ, JP1, K, NM1, NP1 REAL A, B, BJ, ETA, GJ, LJ, LIJ, LJJ, NU, S, THETA, 1 WJ, ZJ REAL ONE, ZERO C C *** DATA INITIALIZATIONS *** C C/6 C DATA ONE/1.E+0/, ZERO/0.E+0/ C/7 PARAMETER (ONE=1.E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NU = ONE ETA = ZERO IF (N .LE. 1) GO TO 30 NM1 = N - 1 C C *** TEMPORARILY STORE S(J) = SUM OVER K = J+1 TO N OF W(K)**2 IN C *** LAMBDA(J). C S = ZERO DO 10 I = 1, NM1 J = N - I S = S + W(J+1)**2 LAMBDA(J) = S 10 CONTINUE C C *** COMPUTE LAMBDA, GAMMA, AND BETA BY GOLDFARB*S RECURRENCE 3. C DO 20 J = 1, NM1 WJ = W(J) A = NU*Z(J) - ETA*WJ THETA = ONE + A*WJ S = A*LAMBDA(J) LJ = SQRT(THETA**2 + A*S) IF (THETA .GT. ZERO) LJ = -LJ LAMBDA(J) = LJ B = THETA*WJ + S GAMMA(J) = B * NU / LJ BETA(J) = (A - B*ETA) / LJ NU = -NU / LJ ETA = -(ETA + (A**2)/(THETA - LJ)) / LJ 20 CONTINUE 30 LAMBDA(N) = ONE + (NU*Z(N) - ETA*W(N))*W(N) C C *** UPDATE L, GRADUALLY OVERWRITING W AND Z WITH L*W AND L*Z. C NP1 = N + 1 JJ = N * (N + 1) / 2 DO 60 K = 1, N J = NP1 - K LJ = LAMBDA(J) LJJ = L(JJ) LPLUS(JJ) = LJ * LJJ WJ = W(J) W(J) = LJJ * WJ ZJ = Z(J) Z(J) = LJJ * ZJ IF (K .EQ. 1) GO TO 50 BJ = BETA(J) GJ = GAMMA(J) IJ = JJ + J JP1 = J + 1 DO 40 I = JP1, N LIJ = L(IJ) LPLUS(IJ) = LJ*LIJ + BJ*W(I) + GJ*Z(I) W(I) = W(I) + LIJ*WJ Z(I) = Z(I) + LIJ*ZJ IJ = IJ + I 40 CONTINUE 50 JJ = JJ - J 60 CONTINUE C 999 RETURN C *** LAST CARD OF L7UPD FOLLOWS *** END SUBROUTINE L7VML(N, X, L, Y) C C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, II, IJ, I0, J, NP1 REAL T, ZERO C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C NP1 = N + 1 I0 = N*(N+1)/2 DO 20 II = 1, N I = NP1 - II I0 = I0 - I T = ZERO DO 10 J = 1, I IJ = I0 + J T = T + L(IJ)*Y(J) 10 CONTINUE X(I) = T 20 CONTINUE 999 RETURN C *** LAST CARD OF L7VML FOLLOWS *** END SUBROUTINE LEAVE C C THIS ROUTINE C C 1) DE-ALLOCATES ALL SCRATCH SPACE ALLOCATED SINCE THE LAST ENTER, C INCLUDING THE LAST ENTER-BLOCK. C 2) RESTORES THE RECOVERY LEVEL TO ITS VALUE C AT THE TIME OF THE LAST CALL TO ENTER. C C ERROR STATES - C C 1 - CANNOT LEAVE BEYOND THE FIRST ENTER. C 2 - ISTACK(INOW) HAS BEEN OVERWRITTEN. C 3 - TOO MANY ISTKRLS OR ISTACK(1 AND/OR INOW) CLOBBERED. C 4 - ISTACK(INOW+1) HAS BEEN OVERWRITTEN. C 5 - ISTACK(INOW+2) HAS BEEN OVERWRITTEN. C COMMON /CSTAK/DSTACK DOUBLE PRECISION DSTACK(500) INTEGER ISTACK(1000) EQUIVALENCE (DSTACK(1),ISTACK(1)) EQUIVALENCE (ISTACK(1),LOUT) C C GET THE POINTER TO THE CURRENT ENTER-BLOCK. C INOW=I8TSEL(-1) C C/6S C IF (INOW.EQ.0) C 1 CALL SETERR(43HLEAVE - CANNOT LEAVE BEYOND THE FIRST ENTER,43, C 2 1,2) C IF (ISTACK(INOW).LT.1) C 1 CALL SETERR(41HLEAVE - ISTACK(INOW) HAS BEEN OVERWRITTEN,41,2,2) C IF (LOUT.LT.ISTACK(INOW)) CALL SETERR( C 1 59HLEAVE - TOO MANY ISTKRLS OR ISTACK(1 AND/OR INOW) CLOBBERED, C 2 59,3,2) C IF (ISTACK(INOW+1).LT.1 .OR. ISTACK(INOW+1).GT.2) C 1 CALL SETERR(43HLEAVE - ISTACK(INOW+1) HAS BEEN OVERWRITTEN, C 2 43,4,2) C IF (ISTACK(INOW+2).GT.INOW-3 .OR. ISTACK(INOW+2).LT.0) C 1 CALL SETERR(43HLEAVE - ISTACK(INOW+2) HAS BEEN OVERWRITTEN, C 2 43,5,2) C/7S IF (INOW.EQ.0) 1 CALL SETERR('LEAVE - CANNOT LEAVE BEYOND THE FIRST ENTER',43, 2 1,2) IF (ISTACK(INOW).LT.1) 1 CALL SETERR('LEAVE - ISTACK(INOW) HAS BEEN OVERWRITTEN',41,2,2) IF (LOUT.LT.ISTACK(INOW)) CALL SETERR( 1 'LEAVE - TOO MANY ISTKRLS OR ISTACK(1 AND/OR INOW) CLOBBERED', 2 59,3,2) IF (ISTACK(INOW+1).LT.1 .OR. ISTACK(INOW+1).GT.2) 1 CALL SETERR('LEAVE - ISTACK(INOW+1) HAS BEEN OVERWRITTEN', 2 43,4,2) IF (ISTACK(INOW+2).GT.INOW-3 .OR. ISTACK(INOW+2).LT.0) 1 CALL SETERR('LEAVE - ISTACK(INOW+2) HAS BEEN OVERWRITTEN', 2 43,5,2) C/ C C DE-ALLOCATE THE SCRATCH SPACE. C CALL ISTKRL(LOUT-ISTACK(INOW)+1) C C RESTORE THE RECOVERY LEVEL. C CALL RETSRC(ISTACK(INOW+1)) C C LOWER THE BACK-POINTER. C ITEMP=I8TSEL(ISTACK(INOW+2)) C RETURN C END SUBROUTINE M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP, * IWA,BWA) INTEGER N,MAXGRP INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),LIST(N),NGRP(N), * IWA(N) LOGICAL BWA(N) C ********** C C SUBROUTINE M7SEQ C C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS C SUBROUTINE DETERMINES A CONSISTENT PARTITION OF THE C COLUMNS OF A BY A SEQUENTIAL ALGORITHM. C C A CONSISTENT PARTITION IS DEFINED IN TERMS OF THE LOOPLESS C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION. C C A PARTITION OF THE COLUMNS OF A INTO GROUPS IS CONSISTENT C IF THE COLUMNS IN ANY GROUP ARE NOT ADJACENT IN THE GRAPH G. C IN GRAPH-THEORY TERMINOLOGY, A CONSISTENT PARTITION OF THE C COLUMNS OF A CORRESPONDS TO A COLORING OF THE GRAPH G. C C THE SUBROUTINE EXAMINES THE COLUMNS IN THE ORDER SPECIFIED C BY THE ARRAY LIST, AND ASSIGNS THE CURRENT COLUMN TO THE C GROUP WITH THE SMALLEST POSSIBLE NUMBER. C C NOTE THAT THE VALUE OF M IS NOT NEEDED BY M7SEQ AND IS C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP, C IWA,BWA) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW C INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. C THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. C THE COLUMN INDICES FOR ROW I ARE C C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. C C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C LIST IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE ORDER TO BE USED BY THE SEQUENTIAL ALGORITHM. C THE J-TH COLUMN IN THIS ORDER IS LIST(J). C C NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS C TO GROUP NGRP(JCOL). C C MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE C NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A. C C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. C C BWA IS A LOGICAL WORK ARRAY OF LENGTH N. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER DEG,IC,IP,IPL,IPU,IR,J,JCOL,JP,JPL,JPU,L,NUMGRP C C INITIALIZATION BLOCK. C MAXGRP = 0 DO 10 JP = 1, N NGRP(JP) = N BWA(JP) = .FALSE. 10 CONTINUE BWA(N) = .TRUE. C C BEGINNING OF ITERATION LOOP. C DO 100 J = 1, N JCOL = LIST(J) C C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. C DEG = 0 C C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND C TO NON-ZEROES IN THE MATRIX. C JPL = JPNTR(JCOL) JPU = JPNTR(JCOL+1) - 1 IF (JPU .LT. JPL) GO TO 50 DO 40 JP = JPL, JPU IR = INDROW(JP) C C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. C IPL = IPNTR(IR) IPU = IPNTR(IR+1) - 1 DO 30 IP = IPL, IPU IC = INDCOL(IP) L = NGRP(IC) C C ARRAY BWA MARKS THE GROUP NUMBERS OF THE C COLUMNS WHICH ARE ADJACENT TO COLUMN JCOL. C ARRAY IWA RECORDS THE MARKED GROUP NUMBERS. C IF (BWA(L)) GO TO 20 BWA(L) = .TRUE. DEG = DEG + 1 IWA(DEG) = L 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE C C ASSIGN THE SMALLEST UN-MARKED GROUP NUMBER TO JCOL. C DO 60 JP = 1, N NUMGRP = JP IF (.NOT. BWA(JP)) GO TO 70 60 CONTINUE 70 CONTINUE NGRP(JCOL) = NUMGRP MAXGRP = MAX0(MAXGRP,NUMGRP) C C UN-MARK THE GROUP NUMBERS. C IF (DEG .LT. 1) GO TO 90 DO 80 JP = 1, DEG L = IWA(JP) BWA(L) = .FALSE. 80 CONTINUE 90 CONTINUE 100 CONTINUE C C END OF ITERATION LOOP. C RETURN C C LAST CARD OF SUBROUTINE M7SEQ. C END SUBROUTINE M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA) INTEGER N,MAXCLQ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N), * LIST(N),IWA1(N),IWA2(N),IWA3(N),IWA4(N) LOGICAL BWA(N) C ********** C C SUBROUTINE M7SLO C C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS C SUBROUTINE DETERMINES THE SMALLEST-LAST ORDERING OF THE C COLUMNS OF A. C C THE SMALLEST-LAST ORDERING IS DEFINED FOR THE LOOPLESS C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION. C C THE SMALLEST-LAST ORDERING IS DETERMINED RECURSIVELY BY C LETTING LIST(K), K = N,...,1 BE A COLUMN WITH LEAST DEGREE C IN THE SUBGRAPH SPANNED BY THE UN-ORDERED COLUMNS. C C NOTE THAT THE VALUE OF M IS NOT NEEDED BY M7SLO AND IS C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, C MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW C INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. C THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. C THE COLUMN INDICES FOR ROW I ARE C C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. C C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN C OF A IS NDEG(J). C C LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES C THE SMALLEST-LAST ORDERING OF THE COLUMNS OF A. THE J-TH C COLUMN IN THIS ORDER IS LIST(J). C C MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE C OF THE LARGEST CLIQUE FOUND DURING THE ORDERING. C C IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N. C C BWA IS A LOGICAL WORK ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... MIN0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER DEG,HEAD,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU, * L,MINDEG,NUMDEG,NUMORD C C INITIALIZATION BLOCK. C MINDEG = N DO 10 JP = 1, N IWA1(JP) = 0 BWA(JP) = .FALSE. LIST(JP) = NDEG(JP) MINDEG = MIN0(MINDEG,NDEG(JP)) 10 CONTINUE C C CREATE A DOUBLY-LINKED LIST TO ACCESS THE DEGREES OF THE C COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS. C C EACH UN-ORDERED COLUMN JCOL IS IN A LIST (THE DEGREE C LIST) OF COLUMNS WITH THE SAME DEGREE. C C IWA1(NUMDEG+1) IS THE FIRST COLUMN IN THE NUMDEG LIST C UNLESS IWA1(NUMDEG+1) = 0. IN THIS CASE THERE ARE C NO COLUMNS IN THE NUMDEG LIST. C C IWA2(JCOL) IS THE COLUMN BEFORE JCOL IN THE DEGREE LIST C UNLESS IWA2(JCOL) = 0. IN THIS CASE JCOL IS THE FIRST C COLUMN IN THIS DEGREE LIST. C C IWA3(JCOL) IS THE COLUMN AFTER JCOL IN THE DEGREE LIST C UNLESS IWA3(JCOL) = 0. IN THIS CASE JCOL IS THE LAST C COLUMN IN THIS DEGREE LIST. C C IF JCOL IS AN UN-ORDERED COLUMN, THEN LIST(JCOL) IS THE C DEGREE OF JCOL IN THE GRAPH INDUCED BY THE UN-ORDERED C COLUMNS. IF JCOL IS AN ORDERED COLUMN, THEN LIST(JCOL) C IS THE SMALLEST-LAST ORDER OF COLUMN JCOL. C DO 20 JP = 1, N NUMDEG = NDEG(JP) HEAD = IWA1(NUMDEG+1) IWA1(NUMDEG+1) = JP IWA2(JP) = 0 IWA3(JP) = HEAD IF (HEAD .GT. 0) IWA2(HEAD) = JP 20 CONTINUE MAXCLQ = 0 NUMORD = N C C BEGINNING OF ITERATION LOOP. C 30 CONTINUE C C MARK THE SIZE OF THE LARGEST CLIQUE C FOUND DURING THE ORDERING. C IF (MINDEG + 1 .EQ. NUMORD .AND. MAXCLQ .EQ. 0) * MAXCLQ = NUMORD C C CHOOSE A COLUMN JCOL OF MINIMAL DEGREE MINDEG. C 40 CONTINUE JCOL = IWA1(MINDEG+1) IF (JCOL .GT. 0) GO TO 50 MINDEG = MINDEG + 1 GO TO 40 50 CONTINUE LIST(JCOL) = NUMORD NUMORD = NUMORD - 1 C C TERMINATION TEST. C IF (NUMORD .EQ. 0) GO TO 120 C C DELETE COLUMN JCOL FROM THE MINDEG LIST. C L = IWA3(JCOL) IWA1(MINDEG+1) = L IF (L .GT. 0) IWA2(L) = 0 C C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. C BWA(JCOL) = .TRUE. DEG = 0 C C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND C TO NON-ZEROES IN THE MATRIX. C JPL = JPNTR(JCOL) JPU = JPNTR(JCOL+1) - 1 IF (JPU .LT. JPL) GO TO 90 DO 80 JP = JPL, JPU IR = INDROW(JP) C C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. C IPL = IPNTR(IR) IPU = IPNTR(IR+1) - 1 DO 70 IP = IPL, IPU IC = INDCOL(IP) C C ARRAY BWA MARKS COLUMNS WHICH ARE ADJACENT TO C COLUMN JCOL. ARRAY IWA4 RECORDS THE MARKED COLUMNS. C IF (BWA(IC)) GO TO 60 BWA(IC) = .TRUE. DEG = DEG + 1 IWA4(DEG) = IC 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE C C UPDATE THE POINTERS TO THE CURRENT DEGREE LISTS. C IF (DEG .LT. 1) GO TO 110 DO 100 JP = 1, DEG IC = IWA4(JP) NUMDEG = LIST(IC) LIST(IC) = LIST(IC) - 1 MINDEG = MIN0(MINDEG,LIST(IC)) C C DELETE COLUMN IC FROM THE NUMDEG LIST. C L = IWA2(IC) IF (L .EQ. 0) IWA1(NUMDEG+1) = IWA3(IC) IF (L .GT. 0) IWA3(L) = IWA3(IC) L = IWA3(IC) IF (L .GT. 0) IWA2(L) = IWA2(IC) C C ADD COLUMN IC TO THE NUMDEG-1 LIST. C HEAD = IWA1(NUMDEG) IWA1(NUMDEG) = IC IWA2(IC) = 0 IWA3(IC) = HEAD IF (HEAD .GT. 0) IWA2(HEAD) = IC C C UN-MARK COLUMN IC IN THE ARRAY BWA. C BWA(IC) = .FALSE. 100 CONTINUE 110 CONTINUE C C END OF ITERATION LOOP. C GO TO 30 120 CONTINUE C C INVERT THE ARRAY LIST. C DO 130 JCOL = 1, N NUMORD = LIST(JCOL) IWA1(NUMORD) = JCOL 130 CONTINUE DO 140 JP = 1, N LIST(JP) = IWA1(JP) 140 CONTINUE RETURN C C LAST CARD OF SUBROUTINE M7SLO. C END SUBROUTINE MNF(N, D, X, CALCF, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER N, LIV, LV INTEGER IV(LIV), UIPARM(1) REAL D(N), X(N), V(LV), URPARM(1) C DIMENSION V(77 + N*(N+17)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, UFPARM C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNF IN AN ATTEMPT C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR MNF ARE THE SAME AS THOSE FOR MNG C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X, C MNF CALLS S7GRD, WHICH COMPUTES AN APPROXIMATION TO THE C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST C IN THIS REGARD (AND IS NOT DESCRIBED IN MNG). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR MNF THAN FOR MNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCE *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, C AND MCS-7906671. C C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL RMNF C C RMNF.... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND C CALLS RMNG TO CARRY OUT MNG ALGORITHM. C INTEGER NF REAL FX C C *** SUBSCRIPTS FOR IV *** C INTEGER NFCALL, TOOBIG C C/6 C DATA NFCALL/6/, TOOBIG/2/ C/7 PARAMETER (NFCALL=6, TOOBIG=2) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C 10 CALL RMNF(D, FX, IV, LIV, LV, N, V, X) IF (IV(1) .GT. 2) GO TO 999 C C *** COMPUTE FUNCTION *** C NF = IV(NFCALL) CALL CALCF(N, X, NF, FX, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 10 C C 999 RETURN C *** LAST CARD OF MNF FOLLOWS *** END SUBROUTINE MNFB(P, D, X, B, CALCF, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER P, LIV, LV C/6S C INTEGER IV(LIV), UIPARM(1) C REAL B(2,P), D(P), X(P), V(LV), URPARM(1) C/7S INTEGER IV(LIV), UIPARM(*) REAL B(2,P), D(P), X(P), V(LV), URPARM(*) C/ C DIMENSION V(59 + P), V(77 + P*(P+23)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, UFPARM C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNF IN AN ATTEMPT C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR MNFB ARE THE SAME AS THOSE FOR MNGB C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X, C MNFB CALLS S3GRD, WHICH COMPUTES AN APPROXIMATION TO THE C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST C IN THIS REGARD (AND IS NOT DESCRIBED IN MNG OR MNGB). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR MNFB THAN FOR MNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCE *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, C AND MCS-7906671. C C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL RMNFB C C RMNFB... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND C CALLS RMNG TO CARRY OUT MNG ALGORITHM. C INTEGER NF REAL FX C C *** SUBSCRIPTS FOR IV *** C INTEGER NFCALL, TOOBIG C C/6 C DATA NFCALL/6/, TOOBIG/2/ C/7 PARAMETER (NFCALL=6, TOOBIG=2) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C 10 CALL RMNFB(B, D, FX, IV, LIV, LV, P, V, X) IF (IV(1) .GT. 2) GO TO 999 C C *** COMPUTE FUNCTION *** C NF = IV(NFCALL) CALL CALCF(P, X, NF, FX, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 10 C C 999 RETURN C *** LAST CARD OF MNFB FOLLOWS *** END SUBROUTINE MNG(N, D, X, CALCF, CALCG, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING *** C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE *** C INTEGER N, LIV, LV INTEGER IV(LIV), UIPARM(1) REAL D(N), X(N), V(LV), URPARM(1) C DIMENSION V(71 + N*(N+15)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, CALCG, UFPARM C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNG IN AN ATTEMPT C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C-------------------------- PARAMETER USAGE -------------------------- C C N........ (INPUT) THE NUMBER OF VARIABLES ON WHICH F DEPENDS, I.E., C THE NUMBER OF COMPONENTS IN X. C D........ (INPUT/OUTPUT) A SCALE VECTOR SUCH THAT D(I)*X(I), C I = 1,2,...,N, ARE ALL IN COMPARABLE UNITS. C D CAN STRONGLY AFFECT THE BEHAVIOR OF MNG. C FINDING THE BEST CHOICE OF D IS GENERALLY A TRIAL- C AND-ERROR PROCESS. CHOOSING D SO THAT D(I)*X(I) C HAS ABOUT THE SAME VALUE FOR ALL I OFTEN WORKS WELL. C THE DEFAULTS PROVIDED BY SUBROUTINE IVSET (SEE IV C BELOW) REQUIRE THE CALLER TO SUPPLY D. C X........ (INPUT/OUTPUT) BEFORE (INITIALLY) CALLING MNG, THE CALL- C ER SHOULD SET X TO AN INITIAL GUESS AT X*. WHEN C MNG RETURNS, X CONTAINS THE BEST POINT SO FAR C FOUND, I.E., THE ONE THAT GIVES THE LEAST VALUE SO C FAR SEEN FOR F(X). C CALCF.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES F(X). CALCF C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C IT IS INVOKED BY C CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) C WHEN CALCF IS CALLED, NF IS THE INVOCATION C COUNT FOR CALCF. NF IS INCLUDED FOR POSSIBLE USE C WITH CALCG. IF X IS OUT OF BOUNDS (E.G., IF IT C WOULD CAUSE OVERFLOW IN COMPUTING F(X)), THEN CALCF C SHOULD SET NF TO 0. THIS WILL CAUSE A SHORTER STEP C TO BE ATTEMPTED. (IF X IS IN BOUNDS, THEN CALCF C SHOULD NOT CHANGE NF.) THE OTHER PARAMETERS ARE AS C DESCRIBED ABOVE AND BELOW. CALCF SHOULD NOT CHANGE C N, P, OR X. C CALCG.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES G(X), THE GRA- C DIENT OF F AT X. CALCG MUST BE DECLARED EXTERNAL IN C THE CALLING PROGRAM. IT IS INVOKED BY C CALL CALCG(N, X, NF, G, UIPARM, URPARM, UFAPRM) C WHEN CALCG IS CALLED, NF IS THE INVOCATION C COUNT FOR CALCF AT THE TIME F(X) WAS EVALUATED. THE C X PASSED TO CALCG IS USUALLY THE ONE PASSED TO CALCF C ON EITHER ITS MOST RECENT INVOCATION OR THE ONE C PRIOR TO IT. IF CALCF SAVES INTERMEDIATE RESULTS C FOR USE BY CALCG, THEN IT IS POSSIBLE TO TELL FROM C NF WHETHER THEY ARE VALID FOR THE CURRENT X (OR C WHICH COPY IS VALID IF TWO COPIES ARE KEPT). IF G C CANNOT BE COMPUTED AT X, THEN CALCG SHOULD SET NF TO C 0. IN THIS CASE, MNG WILL RETURN WITH IV(1) = 65. C (IF G CAN BE COMPUTED AT X, THEN CALCG SHOULD NOT C CHANGED NF.) THE OTHER PARAMETERS TO CALCG ARE AS C DESCRIBED ABOVE AND BELOW. CALCG SHOULD NOT CHANGE C N OR X. C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH LIV (SEE C BELOW) THAT HELPS CONTROL THE MNG ALGORITHM AND C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI- C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/ C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC- C TION EVALUATIONS. SEE THE SECTION ON IV INPUT C VALUES BELOW. C LIV...... (INPUT) LENGTH OF IV ARRAY. MUST BE AT LEAST 60. IF LIV C IS TOO SMALL, THEN MNG RETURNS WITH IV(1) = 15. C WHEN MNG RETURNS, THE SMALLEST ALLOWED VALUE OF C LIV IS STORED IN IV(LASTIV) -- SEE THE SECTION ON C IV OUTPUT VALUES BELOW. (THIS IS INTENDED FOR USE C WITH EXTENSIONS OF MNG THAT HANDLE CONSTRAINTS.) C LV....... (INPUT) LENGTH OF V ARRAY. MUST BE AT LEAST 71+N*(N+15)/2. C (AT LEAST 77+N*(N+17)/2 FOR MNF, AT LEAST C 78+N*(N+12) FOR MNH). IF LV IS TOO SMALL, THEN C MNG RETURNS WITH IV(1) = 16. WHEN MNG RETURNS, C THE SMALLEST ALLOWED VALUE OF LV IS STORED IN C IV(LASTV) -- SEE THE SECTION ON IV OUTPUT VALUES C BELOW. C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH LV C (SEE BELOW) THAT HELPS CONTROL THE MNG ALGORITHM C AND THAT IS USED TO STORE VARIOUS INTERMEDIATE C QUANTITIES. OF PARTICULAR INTEREST ARE THE ENTRIES C IN V THAT LIMIT THE LENGTH OF THE FIRST STEP C ATTEMPTED (LMAX0) AND SPECIFY CONVERGENCE TOLERANCES C (AFCTOL, LMAXS, RFCTOL, SCTOL, XCTOL, XFTOL). C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE C TO CALCF AND CALCG. C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT C CHANGE TO CALCF AND CALCG. C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT C CHANGE TO CALCF AND CALCG. C C *** IV INPUT VALUES (FROM SUBROUTINE IVSET) *** C C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 14...... C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT C IVSET(2, IV, LIV, LV, V) C IS TO BE CALLED TO PROVIDE ALL DEFAULT VALUES TO IV AND C V. 12 (THE VALUE THAT IVSET ASSIGNS TO IV(1)) MEANS THE C CALLER HAS ALREADY CALLED IVSET AND HAS POSSIBLY CHANGED C SOME IV AND/OR V ENTRIES TO NON-DEFAULT VALUES. C 13 MEANS IVSET HAS BEEN CALLED AND THAT MNG (AND C RMNG) SHOULD ONLY DO THEIR STORAGE ALLOCATION. THAT IS, C THEY SHOULD SET THE OUTPUT COMPONENTS OF IV THAT TELL C WHERE VARIOUS SUBARRAYS ARRAYS OF V BEGIN, SUCH AS IV(G) C (AND, FOR MNH AND RMNH ONLY, IV(DTOL)), AND RETURN. C 14 MEANS THAT A STORAGE HAS BEEN ALLOCATED (BY A CALL C WITH IV(1) = 13) AND THAT THE ALGORITHM SHOULD BE C STARTED. WHEN CALLED WITH IV(1) = 13, MNG RETURNS C IV(1) = 14 UNLESS LIV OR LV IS TOO SMALL (OR N IS NOT C POSITIVE). DEFAULT = 12. C IV(INITH).... IV(25) TELLS WHETHER THE HESSIAN APPROXIMATION H SHOULD C BE INITIALIZED. 1 (THE DEFAULT) MEANS RMNG SHOULD C INITIALIZE H TO THE DIAGONAL MATRIX WHOSE I-TH DIAGONAL C ELEMENT IS D(I)**2. 0 MEANS THE CALLER HAS SUPPLIED A C CHOLESKY FACTOR L OF THE INITIAL HESSIAN APPROXIMATION C H = L*(L**T) IN V, STARTING AT V(IV(LMAT)) = V(IV(42)) C (AND STORED COMPACTLY BY ROWS). NOTE THAT IV(LMAT) MAY C BE INITIALIZED BY CALLING MNG WITH IV(1) = 13 (SEE C THE IV(1) DISCUSSION ABOVE). DEFAULT = 1. C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS C (CALLS ON CALCF) ALLOWED. IF THIS NUMBER DOES NOT SUF- C FICE, THEN MNG RETURNS WITH IV(1) = 9. DEFAULT = 200. C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA- C TIONS (CALLS ON CALCG) TO IV(MXITER) + 1. IF IV(MXITER) C ITERATIONS DO NOT SUFFICE, THEN MNG RETURNS WITH C IV(1) = 10. DEFAULT = 150. C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM- C MARY LINES PRINTED (BY ITSUM). IV(OUTLEV) = 0 MEANS DO C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV) C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 78 (PLUS CARRI- C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE C ITERATION AND FUNCTION EVALUATION COUNTS, F = THE CURRENT C FUNCTION VALUE, RELATIVE DIFFERENCE IN FUNCTION VALUES C ACHIEVED BY THE LATEST STEP (I.E., RELDF = (F0-V(F))/F01, C WHERE F01 IS THE MAXIMUM OF ABS(V(F)) AND ABS(V(F0)) AND C V(F0) IS THE FUNCTION VALUE FROM THE PREVIOUS ITERA- C TION), THE RELATIVE FUNCTION REDUCTION PREDICTED FOR THE C STEP JUST TAKEN (I.E., PRELDF = V(PREDUC) / F01, WHERE C V(PREDUC) IS DESCRIBED BELOW), THE SCALED RELATIVE CHANGE C IN X (SEE V(RELDX) BELOW), THE STEP PARAMETER FOR THE C STEP JUST TAKEN (STPPAR = 0 MEANS A FULL NEWTON STEP, C BETWEEN 0 AND 1 MEANS A RELAXED NEWTON STEP, BETWEEN 1 C AND 2 MEANS A DOUBLE DOGLEG STEP, GREATER THAN 2 MEANS C A SCALED DOWN CAUCHY STEP -- SEE SUBROUTINE DBLDOG), THE C 2-NORM OF THE SCALE VECTOR D TIMES THE STEP JUST TAKEN C (SEE V(DSTNRM) BELOW), AND NPRELDF, I.E., C V(NREDUC)/F01, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH C STPPAR = 0). IF NPRELDF IS NEGATIVE, THEN IT IS THE C NEGATIVE OF THE RELATIVE FUNCTION REDUCTION PREDICTED C FOR A STEP COMPUTED WITH STEP BOUND V(LMAXS) FOR USE IN C TESTING FOR SINGULAR CONVERGENCE. C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF LENGTH 50 C ARE PRINTED, INCLUDING ONLY THE FIRST 6 ITEMS LISTED C ABOVE (THROUGH RELDX). C DEFAULT = 1. C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A C FRESH START OR ANY CHANGED V VALUES ON A RESTART. C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING. C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS). C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS C WELL AS THE GRADIENT AND THE SCALE VECTOR D). C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN- C ING. THESE CONSIST OF THE FUNCTION VALUE, THE SCALED C RELATIVE CHANGE IN X CAUSED BY THE MOST RECENT STEP (SEE C V(RELDX) BELOW), THE NUMBER OF FUNCTION AND GRADIENT C EVALUATIONS (CALLS ON CALCF AND CALCG), AND THE RELATIVE C FUNCTION REDUCTIONS PREDICTED FOR THE LAST STEP TAKEN AND C FOR A NEWTON STEP (OR PERHAPS A STEP BOUNDED BY V(LMAXS) C -- SEE THE DESCRIPTIONS OF PRELDF AND NPRELDF UNDER C IV(OUTLEV) ABOVE). C IV(STATPR) = 0 MEANS SKIP THIS PRINTING. C IV(STATPR) = -1 MEANS SKIP THIS PRINTING AS WELL AS THAT C OF THE ONE-LINE TERMINATION REASON MESSAGE. DEFAULT = 1. C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS C PRINTING. DEFAULT = 1. C C *** (SELECTED) IV OUTPUT VALUES *** C C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE.... C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE (SEE C V(RELDX)) BETWEEN THE CURRENT PARAMETER VECTOR X AND C A LOCALLY OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT C MOST V(XCTOL). C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER- C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO- C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL). C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD). C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE. C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A C STEP OF LENGTH AT MOST V(LMAXS) IS UNLIKELY TO YIELD C A RELATIVE FUNCTION DECREASE OF MORE THAN V(SCTOL). C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG- C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL), C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X. C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON- C VERGENCE (SEE IV(MXFCAL)). C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE C (SEE IV(MXITER)). C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT). SEE THE C USAGE NOTES BELOW. C 14 = STORAGE HAS BEEN ALLOCATED (AFTER A CALL WITH C IV(1) = 13). C 17 = RESTART ATTEMPTED WITH N CHANGED. C 18 = D HAS A NEGATIVE COMPONENT AND IV(DTYPE) .LE. 0. C 19...43 = V(IV(1)) IS OUT OF RANGE. C 63 = F(X) CANNOT BE COMPUTED AT THE INITIAL X. C 64 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT C OCCUR). C 65 = THE GRADIENT COULD NOT BE COMPUTED AT X (SEE CALCG C ABOVE). C 67 = BAD FIRST PARAMETER TO IVSET. C 80 = IV(1) WAS OUT OF RANGE. C 81 = N IS NOT POSITIVE. C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C GRADIENT VECTOR (THE ONE CORRESPONDING TO X). C IV(LASTIV)... IV(44) IS THE LEAST ACCEPTABLE VALUE OF LIV. (IT IS C ONLY SET IF LIV IS AT LEAST 44.) C IV(LASTV).... IV(45) IS THE LEAST ACCEPTABLE VALUE OF LV. (IT IS C ONLY SET IF LIV IS LARGE ENOUGH, AT LEAST IV(LASTIV).) C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS). C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON C CALCG). C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED. C C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE IVSET) *** C C V(BIAS)..... V(43) IS THE BIAS PARAMETER USED IN SUBROUTINE DBLDOG -- C SEE THAT SUBROUTINE FOR DETAILS. DEFAULT = 0.8. C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. C IF MNG FINDS A POINT WHERE THE FUNCTION VALUE IS LESS C THAN V(AFCTOL) IN ABSOLUTE VALUE, AND IF MNG DOES NOT C RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS WITH C IV(1) = 6. THIS TEST CAN BE TURNED OFF BY SETTING C V(AFCTOL) TO ZERO. DEFAULT = MAX(10**-20, MACHEP**2), C WHERE MACHEP IS THE UNIT ROUNDOFF. C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE C VECTOR D IS INITIALIZED. DEFAULT = -1. C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE C VERY FIRST STEP THAT MNG ATTEMPTS. THIS PARAMETER CAN C MARKEDLY AFFECT THE PERFORMANCE OF MNG. C V(LMAXS).... V(36) IS USED IN TESTING FOR SINGULAR CONVERGENCE -- IF C THE FUNCTION REDUCTION PREDICTED FOR A STEP OF LENGTH C BOUNDED BY V(LMAXS) IS AT MOST V(SCTOL) * ABS(F0), WHERE C F0 IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION, AND IF MNG DOES NOT RETURN WITH IV(1) = 3, C 4, 5, OR 6, THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 1. C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE. C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) C AT THE START OF THE CURRENT ITERATION, WHERE F0 IS THE C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT- C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION C DECREASE, THEN MNG RETURNS WITH IV(1) = 4 (OR 5). C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS C THE UNIT ROUNDOFF. C V(SCTOL).... V(37) IS THE SINGULAR CONVERGENCE TOLERANCE -- SEE THE C DESCRIPTION OF V(LMAXS) ABOVE. C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE. C THIS IS DONE IF THE ACTUAL FUNCTION DECREASE FROM THE C CURRENT STEP IS NO MORE THAN V(TUNER1) TIMES ITS PREDICT- C ED VALUE. DEFAULT = 0.1. C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL) C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC- C TION DECREASE, THEN MNG RETURNS WITH IV(1) = 3 (OR 5). C (SEE THE DESCRIPTION OF V(RELDX) BELOW.) C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF. C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT- C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL), C AND IF MNG DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(*)........ IVSET SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE C SECTION 17 OF VERSION 2.2 OF THE NL2SOL USAGE SUMMARY C (I.E., THE APPENDIX TO REF. 1) FOR DETAILS ON V(I), C I = DECFAC, INCFAC, PHMNFC, PHMXFC, RDFCMN, RDFCMX, C TUNER2, TUNER3, TUNER4, TUNER5. C C *** (SELECTED) V OUTPUT VALUES *** C C V(DGNORM)... V(1) IS THE 2-NORM OF (DIAG(D)**-1)*G, WHERE G IS THE C MOST RECENTLY COMPUTED GRADIENT. C V(DSTNRM)... V(2) IS THE 2-NORM OF DIAG(D)*STEP, WHERE STEP IS THE C CURRENT STEP. C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE. C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION. C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC- C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E., C STEP = -H**-1 * G, WHERE G IS THE CURRENT GRADIENT AND C H IS THE CURRENT HESSIAN APPROXIMATION). C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH C A STEP BOUND OF V(LMAXS) FOR USE IN TESTING FOR SINGULAR C CONVERGENCE. C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION C CONVERGENCE. C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE C CURRENT STEP, COMPUTED AS C MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P), C WHERE X = X0 + STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C THIS ROUTINE USES A HESSIAN APPROXIMATION COMPUTED FROM THE C BFGS UPDATE (SEE REF 3). ONLY A CHOLESKY FACTOR OF THE HESSIAN C APPROXIMATION IS STORED, AND THIS IS UPDATED USING IDEAS FROM C REF. 4. STEPS ARE COMPUTED BY THE DOUBLE DOGLEG SCHEME DESCRIBED C IN REF. 2. THE STEPS ARE ASSESSED AS IN REF. 1. C C *** USAGE NOTES *** C C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART, C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT- C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY IVSET). C THOSE WHO DO NOT WISH TO WRITE A CALCG WHICH COMPUTES THE C GRADIENT ANALYTICALLY SHOULD CALL MNF RATHER THAN MNG. C MNF USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE GRADIENT. C THOSE WHO WOULD PREFER TO PROVIDE F AND G (THE FUNCTION AND C GRADIENT) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU- C TINES CALCF AND CALCG MAY CALL ON RMNG DIRECTLY. SEE THE COM- C MENTS AT THE BEGINNING OF RMNG. C THOSE WHO USE MNG INTERACTIVELY MAY WISH TO SUPPLY THEIR C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT C POSSIBLE TO EXTERNALLY INTERRUPT MNG (WHICH WILL RETURN WITH C IV(1) = 11 IF STOPX RETURNS .TRUE.). C STORAGE FOR G IS ALLOCATED AT THE END OF V. THUS THE CALLER C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCG TO USE C ELEMENTS OF G BEYOND THE FIRST N AS SCRATCH STORAGE. C C *** PORTABILITY NOTES *** C C THE MNG DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE- C PRECISION VERSIONS OF THE MNG SOURCE CODE, SO IT SHOULD BE UN- C NECESSARY TO CHANGE PRECISIONS. C ONLY THE FUNCTIONS I7MDCN AND R7MDC CONTAIN MACHINE-DEPENDENT C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS. C INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED. ON CERTAIN COM- C PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE C DECLARATIONS. SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE C PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+ C IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY C A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72. C THE MNG SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD C FORTRAN. IT MAY BE CONVERTED TO FORTRAN 77 BY COMMENTING OUT ALL C LINES THAT FALL BETWEEN A LINE HAVING C/6 IN COLUMNS 1-3 AND A C LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING (I.E., REPLACING C BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT FOLLOW THE C/7 C LINE AND PRECEDE A LINE HAVING C/ IN COLUMNS 1-2 AND BLANKS IN C COLUMNS 3-72. THESE CHANGES CONVERT SOME DATA STATEMENTS INTO C PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM REAL TO C CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE THESE C VARIABLES USE CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD C OF HOLLERITH CONSTANTS. (SUCH VARIABLES AND DATA STATEMENTS C APPEAR ONLY IN MODULES ITSUM AND PARCK. PARAMETER STATEMENTS C APPEAR NEARLY EVERYWHERE.) THESE CHANGES ALSO ADD SAVE STATE- C MENTS FOR VARIABLES GIVEN MACHINE-DEPENDENT CONSTANTS BY R7MDC. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), ALGORITHM 573 -- C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. C MATH. SOFTWARE 7, PP. 369-383. C C 2. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI- C MIZATION ALGORITHMS WHICH USE FUNCTION AND GRADIENT C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482. C C 3. DENNIS, J.E., AND MORE, J.J. (1977), QUASI-NEWTON METHODS, MOTIVA- C TION AND THEORY, SIAM REV. 19, PP. 46-89. C C 4. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON- C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811. C C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SUMMER 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, C AND MCS-7906671. C. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL IVSET, RMNG C C IVSET... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C RMNG... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT MNG ALGO- C RITHM. C INTEGER G1, IV1, NF REAL F C C *** SUBSCRIPTS FOR IV *** C INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + N IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) C 20 CALL RMNG(D, F, V(G1), IV, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 50 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 50 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(NEXTV) = IV(G) + N IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF MNG FOLLOWS *** END SUBROUTINE MNGB(N, D, X, B, CALCF, CALCG, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING *** C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE *** C INTEGER N, LIV, LV C/6S C INTEGER IV(LIV), UIPARM(1) C REAL D(N), X(N), B(2,N), V(LV), URPARM(1) C/7S INTEGER IV(LIV), UIPARM(*) REAL D(N), X(N), B(2,N), V(LV), URPARM(*) C/ C DIMENSION IV(59 + N), V(71 + N*(N+21)/2), UIPARM(*), URPARM(*) EXTERNAL CALCF, CALCG, UFPARM C C *** DISCUSSION *** C C THIS ROUTINE IS LIKE MNG, EXCEPT FOR THE EXTRA PARAMETER B, C AN ARRAY OF LOWER AND UPPER BOUNDS ON X... MNGB ENFORCES THE C CONSTRAINTS THAT B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)N. C (INSTEAD OF CALLING RMNG, MNGB CALLS RMNGB.) C. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL IVSET, RMNGB C C IVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C RMNGB... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT MNG ALGO- C RITHM. C INTEGER G1, IV1, NF REAL F C C *** SUBSCRIPTS FOR IV *** C INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N CALL RMNGB(B, D, F, V, IV, LIV, LV, N, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(NEXTV) = IV(G) + N IF (IV1 .EQ. 13) GO TO 999 C 10 G1 = IV(G) C 20 CALL RMNGB(B, D, F, V(G1), IV, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 999 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C *** LAST CARD OF MNGB FOLLOWS *** END SUBROUTINE MNH(N, D, X, CALCF, CALCGH, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING *** C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. *** C INTEGER LIV, LV, N INTEGER IV(LIV), UIPARM(1) REAL D(N), X(N), V(LV), URPARM(1) C DIMENSION V(78 + N*(N+12)), UIPARM(*), URPARM(*) EXTERNAL CALCF, CALCGH, UFPARM C C------------------------------ DISCUSSION --------------------------- C C THIS ROUTINE IS LIKE MNG, EXCEPT THAT THE SUBROUTINE PARA- C METER CALCG OF MNG (WHICH COMPUTES THE GRADIENT OF THE OBJEC- C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH, C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE) C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS... C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM) C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME C AS FOR MNG, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START- C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... C THE VALUE PRINTED (BY ITSUM) IN THE COLUMN LABELLED STPPAR C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP. C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN C IS NOT POSITIVE DEFINITE. C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT... C C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE C INITIALIZED BY CALLING MNH WITH IV(1) = 13.) C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN. C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0. C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT), DESCRIBED IN MNG.) LET C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)), C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), DTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED DTOL IN V STARTING AT V(IV(DTOL)). C DEFAULT = 10**-6. C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0. C C *** REFERENCE *** C C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL IVSET, RMNH C C IVSET... PROVIDES DEFAULT INPUT VALUES FOR IV AND V. C RMNH... REVERSE-COMMUNICATION ROUTINE THAT DOES MNH ALGORITHM. C INTEGER G1, H1, IV1, LH, NF REAL F C C *** SUBSCRIPTS FOR IV *** C INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/, C 1 VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2, 1 VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = N * (N + 1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13) 1 IV(VNEED) = IV(VNEED) + N*(N+3)/2 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 H1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) H1 = IV(H) C 20 CALL RMNH(D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 50 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 50 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(H) = IV(G) + N IV(NEXTV) = IV(H) + N*(N+1)/2 IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF MNH FOLLOWS *** END SUBROUTINE MNHB(N, D, X, B, CALCF, CALCGH, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING *** C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. *** C INTEGER LIV, LV, N C/6S C INTEGER IV(LIV), UIPARM(1) C REAL B(2,N), D(N), X(N), V(LV), URPARM(1) C/7S INTEGER IV(LIV), UIPARM(*) REAL B(2,N), D(N), X(N), V(LV), URPARM(*) C/ C DIMENSION IV(59 + 3*N), V(78 + N*(N+15)) EXTERNAL CALCF, CALCGH, UFPARM C C------------------------------ DISCUSSION --------------------------- C C THIS ROUTINE IS LIKE MNGB, EXCEPT THAT THE SUBROUTINE PARA- C METER CALCG OF MNGB (WHICH COMPUTES THE GRADIENT OF THE OBJEC- C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH, C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE) C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS... C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM) C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME C AS FOR MNGB, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START- C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... C THE VALUE PRINTED (BY ITSUM) IN THE COLUMN LABELLED STPPAR C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP. C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN C IS NOT POSITIVE DEFINITE. C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT... C C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE C INITIALIZED BY CALLING MNHB WITH IV(1) = 13.) C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN. C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0. C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT), DESCRIBED IN MNG.) LET C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)), C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), DTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED DTOL IN V STARTING AT V(IV(DTOL)). C DEFAULT = 10**-6. C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0. C C *** REFERENCE *** C C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER, SPRING 1983). C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL IVSET, RMNHB C C IVSET.... PROVIDES DEFAULT INPUT VALUES FOR IV AND V. C RMNHB... REVERSE-COMMUNICATION ROUTINE THAT DOES MNHB ALGORITHM. C INTEGER G1, H1, IV1, LH, NF REAL F C C *** SUBSCRIPTS FOR IV *** C INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED C C/6 C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/, C 1 VNEED/4/ C/7 PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2, 1 VNEED=4) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = N * (N + 1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N*(N+3)/2 CALL RMNHB(B, D, F, V, V, IV, LH, LIV, LV, N, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION C IV(G) = IV(NEXTV) IV(H) = IV(G) + N IV(NEXTV) = IV(H) + N*(N+1)/2 IF (IV1 .EQ. 13) GO TO 999 C 10 G1 = IV(G) H1 = IV(H) C 20 CALL RMNHB(B, D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X) IF (IV(1) - 2) 30, 40, 999 C 30 NF = IV(NFCALL) CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 40 NF = IV(NFGCAL) CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C *** LAST CARD OF MNHB FOLLOWS *** END SUBROUTINE MOVEBC(N,A,B) C C MOVEBC MOVES N COMPLEX ITEMS FROM A TO B C USING A BACKWARDS DO LOOP C C/R C REAL A(2,N), B(2,N) C/C COMPLEX A(1),B(1) C/ C I = N C 10 IF(I .LE. 0) RETURN C/R C B(2,I) = A(2,I) C B(1,I) = A(1,I) C/C B(I) = A(I) C/ I = I - 1 GO TO 10 C END SUBROUTINE MOVEBD(N,A,B) C C MOVEBD MOVES N DOUBLE PRECISION ITEMS FROM A TO B C USING A BACKWARDS DO LOOP C DOUBLE PRECISION A(1),B(1) C I = N C 10 IF(I .LE. 0) RETURN B(I) = A(I) I = I - 1 GO TO 10 C END SUBROUTINE MOVEBI(N,A,B) C C MOVEBI MOVES N INTEGER ITEMS FROM A TO B C USING A BACKWARDS DO LOOP C INTEGER A(1),B(1) C I = N C 10 IF(I .LE. 0) RETURN B(I) = A(I) I = I - 1 GO TO 10 C END SUBROUTINE MOVEBL(N,A,B) C C MOVEBL MOVES N LOGICAL ITEMS FROM A TO B C USING A BACKWARDS DO LOOP C LOGICAL A(1),B(1) C I = N C 10 IF(I .LE. 0) RETURN B(I) = A(I) I = I - 1 GO TO 10 C END SUBROUTINE MOVEBR(N,A,B) C C MOVEBR MOVES N REAL ITEMS FROM A TO B C USING A BACKWARDS DO LOOP C REAL A(1),B(1) C I = N C 10 IF(I .LE. 0) RETURN B(I) = A(I) I = I - 1 GO TO 10 C END SUBROUTINE MOVEFC(N,A,B) C C MOVEFC MOVES N COMPLEX ITEMS FROM A TO B C USING A FORWARDS DO LOOP C C/R C REAL A(2,N), B(2,N) C/C COMPLEX A(1),B(1) C/ C IF(N .LE. 0) RETURN C DO 10 I = 1, N C/R C B(1,I) = A(1,I) C10 B(2,I) = A(2,I) C/C 10 B(I) = A(I) C/ C RETURN C END SUBROUTINE MOVEFD(N,A,B) C C MOVEFD MOVES N DOUBLE PRECISION ITEMS FROM A TO B C USING A FORWARDS DO LOOP C DOUBLE PRECISION A(1),B(1) C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = A(I) C RETURN C END SUBROUTINE MOVEFI(N,A,B) C C MOVEFI MOVES N INTEGER ITEMS FROM A TO B C USING A FORWARDS DO LOOP C INTEGER A(1),B(1) C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = A(I) C RETURN C END SUBROUTINE MOVEFL(N,A,B) C C MOVEFL MOVES N LOGICAL ITEMS FROM A TO B C USING A FORWARDS DO LOOP C LOGICAL A(1),B(1) C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = A(I) C RETURN C END SUBROUTINE MOVEFR(N,A,B) C C MOVEFR MOVES N REAL ITEMS FROM A TO B C USING A FORWARDS DO LOOP C REAL A(1),B(1) C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = A(I) C RETURN C END INTEGER FUNCTION MTSTAK(NITEMS) C CALL I0TK01 MTSTAK = ISTKMD(NITEMS) C RETURN C END SUBROUTINE N2CVP(IV, LIV, LV, P, V) C C *** PRINT COVARIANCE MATRIX FOR RN2G *** C INTEGER LIV, LV, P INTEGER IV(LIV) REAL V(LV) C C *** LOCAL VARIABLES *** C INTEGER COV1, I, II, I1, J, PU REAL T C C *** IV SUBSCRIPTS *** C INTEGER COVMAT, COVPRT, COVREQ, NEEDHD, NFCOV, NGCOV, PRUNIT, 1 RCOND, REGD, STATPR C C/6 C DATA COVMAT/26/, COVPRT/14/, COVREQ/15/, NEEDHD/36/, NFCOV/52/, C 1 NGCOV/53/, PRUNIT/21/, RCOND/53/, REGD/67/, STATPR/23/ C/7 PARAMETER (COVMAT=26, COVPRT=14, COVREQ=15, NEEDHD=36, NFCOV=52, 1 NGCOV=53, PRUNIT=21, RCOND=53, REGD=67, STATPR=23) C/ C *** BODY *** C IF (IV(1) .GT. 8) GO TO 999 PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (IV(STATPR) .EQ. 0) GO TO 30 IF (IV(NFCOV) .GT. 0) WRITE(PU,10) IV(NFCOV) 10 FORMAT(/1X,I4,50H EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOST 1ICS.) IF (IV(NGCOV) .GT. 0) WRITE(PU,20) IV(NGCOV) 20 FORMAT(1X,I4,50H EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTI 1CS.) C 30 IF (IV(COVPRT) .LE. 0) GO TO 999 COV1 = IV(COVMAT) IF (IV(REGD) .LE. 0 .AND. COV1 .LE. 0) GO TO 70 IV(NEEDHD) = 1 T = V(RCOND)**2 IF (IABS(IV(COVREQ)) .GT. 2) GO TO 50 C WRITE(PU,40) T 40 FORMAT(/47H RECIPROCAL CONDITION OF F.D. HESSIAN = AT MOST,E10.2) GO TO 70 C 50 WRITE(PU,60) T 60 FORMAT(/44H RECIPROCAL CONDITION OF (J**T)*J = AT LEAST,E10.2) C 70 IF (MOD(IV(COVPRT),2) .EQ. 0) GO TO 999 IV(NEEDHD) = 1 IF (COV1) 80,110,130 80 IF (-1 .EQ. COV1) WRITE(PU,90) 90 FORMAT(/43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,100) 100 FORMAT(/52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 110 WRITE(PU,120) 120 FORMAT(/45H ++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 999 C 130 I = IABS(IV(COVREQ)) IF (I .LE. 1) WRITE(PU,140) 140 FORMAT(/48H COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/ 1 23H WHERE H = F.D. HESSIAN/) IF (I .EQ. 2) WRITE(PU,150) 150 FORMAT(/56H COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIA 1N/) IF (I .GT. 2) WRITE(PU,160) 160 FORMAT(/30H COVARIANCE = SCALE * J**T * J/) II = COV1 - 1 DO 170 I = 1, P I1 = II + 1 II = II + I WRITE(PU,180) I, (V(J), J = I1, II) 170 CONTINUE 180 FORMAT(4H ROW,I3,2X,5E12.3/(9X,5E12.3)) C 999 RETURN C *** LAST CARD OF N2CVP FOLLOWS *** END SUBROUTINE N2F(N, P, X, CALCR, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY.. C *** THIS AMOUNTS TO N2G WITHOUT THE SUBROUTINE PARAMETER CALCJ. C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UIPARM(1) C REAL X(P), V(LV), URPARM(1) C/7 INTEGER IV(LIV), UIPARM(*) REAL X(P), V(LV), URPARM(*) C/ EXTERNAL CALCR, UFPARM C C----------------------------- DISCUSSION ---------------------------- C C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO CALL C RN2G. C THE PARAMETERS FOR N2F ARE THE SAME AS THOSE FOR N2G C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, N2F COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. N2F USES FUNCTION VALUES ONLY WHEN COMPUT- C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS C THAT N2G MAY USE). TO DO SO, N2F SETS IV(COVREQ) TO MINUS C ITS ABSOLUTE VALUE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC). C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD. C C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. C C *** REFERENCE *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RN2G, N2RDP, V7SCP C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RN2G... CARRIES OUT OPTIMIZATION ITERATIONS. C N2RDP... PRINTS REGRESSION DIAGNOSTICS. C V7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN REAL H, H0, HLIM, NEGPT5, ONE, XK, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, REGD, REGD0, TOOBIG, VNEED C/6 C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/, C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/, C 2 R/61/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, REGD=67, REGD0=82, TOOBIG=2, VNEED=4) C/ DATA HLIM/0.1E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL RN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RN = R1 + N - 1 RD1 = IV(REGD0) C 20 CALL RN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 100 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL V7SCP(P, V(D1), ONE) C J1K = DR1 DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 DO 90 K = 1, P XK = X(K) H = V(DLTFDJ) * AMAX1( ABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 60 X(K) = XK + H NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM) NG = NG + 1 IF (NF .GT. 0) GO TO 70 H = NEGPT5 * H IF ( ABS(H/H0) .GE. HLIM) GO TO 60 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 70 X(K) = XK IV(NGCALL) = NG DO 80 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 80 CONTINUE 90 CONTINUE GO TO 20 C 100 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 CALL N2RDP(IV, LIV, LV, N, V(RD1), V) C 999 RETURN C C *** LAST LINE OF N2F FOLLOWS *** END SUBROUTINE N2FB(N, P, X, B, CALCR, IV, LIV, LV, V, UI, UR, UF) C C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY.. C *** THIS AMOUNTS TO N2G WITHOUT THE SUBROUTINE PARAMETER CALCJ. C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C REAL X(P), B(2,P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) REAL X(P), B(2,P), V(LV), UR(*) C/ EXTERNAL CALCR, UF C C----------------------------- DISCUSSION ---------------------------- C C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO HANDLE C SIMPLE BOUNDS ON THE VARIABLES... C B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P. C THE PARAMETERS FOR N2FB ARE THE SAME AS THOSE FOR N2GB C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, N2FB COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. N2FB DOES NOT COMPUTE A COVARIANCE MATRIX. C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD. C C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. C C *** REFERENCE *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RN2GB, V7SCP C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RN2GB... CARRIES OUT OPTIMIZATION ITERATIONS. C N2RDP... PRINTS REGRESSION DIAGNOSTICS. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN REAL H, H0, HLIM, NEGPT5, ONE, T, XK, XK1, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, REGD0, TOOBIG, VNEED C/6 C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/, C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/, C 2 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, REGD0=82, TOOBIG=2, VNEED=4) C/ DATA HLIM/0.1E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV(COVREQ) = 0 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL RN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RN = R1 + N - 1 RD1 = IV(REGD0) C 20 CALL RN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL V7SCP(P, V(D1), ONE) C J1K = DR1 DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 DO 120 K = 1, P IF (B(1,K) .GE. B(2,K)) GO TO 110 XK = X(K) H = V(DLTFDJ) * AMAX1( ABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 T = NEGPT5 XK1 = XK + H IF (XK - H .GE. B(1,K)) GO TO 60 T = -T IF (XK1 .GT. B(2,K)) GO TO 80 60 IF (XK1 .LE. B(2,K)) GO TO 70 T = -T H = -H XK1 = XK + H IF (XK1 .LT. B(1,K)) GO TO 80 70 X(K) = XK1 NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UI, UR, UF) NG = NG + 1 IF (NF .GT. 0) GO TO 90 H = T * H XK1 = XK + H IF ( ABS(H/H0) .GE. HLIM) GO TO 70 80 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 90 X(K) = XK IV(NGCALL) = NG DO 100 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 100 CONTINUE GO TO 120 C *** SUPPLY A ZERO DERIVATIVE FOR CONSTANT COMPONENTS... 110 CALL V7SCP(N, V(J1K), ZERO) J1K = J1K + N 120 CONTINUE GO TO 20 C 999 RETURN C C *** LAST CARD OF N2FB FOLLOWS *** END SUBROUTINE N2G(N, P, X, CALCR, CALCJ, IV, LIV, LV, V, 1 UI, UR, UF) C C *** VERSION OF NL2SOL THAT CALLS RN2G *** C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C REAL X(P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) REAL X(P), V(LV), UR(*) C/ EXTERNAL CALCR, CALCJ, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST C PARTIALS OF THE RESIDUAL VECTOR. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C UI...... PASSED UNCHANGED TO CALCR AND CALCJ. C UR...... PASSED UNCHANGED TO CALCR AND CALCJ. C UF...... PASSED UNCHANGED TO CALCR AND CALCJ. C C C *** DISCUSSION *** C C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383 C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, C D.M. GAY, AND R.E. WELSCH). C C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82+P. IF NOT, C THEN N2G RETURNS WITH IV(1) = 15. WHEN N2G RETURNS, THE C MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN IV(LASTIV) = IV(44), C (PROVIDED THAT LIV .GE. 44). C C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS C LV0 = 105 + P*(N + 2*P + 17) + 2*N. IF LV IS SMALLER THAN THIS, C THEN N2G RETURNS WITH IV(1) = 16. WHEN N2G RETURNS, THE C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45) C (PROVIDED LIV .GE. 45). C C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL. C C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION. C C *** DEFAULT VALUES *** C C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE IVSET, RATHER THAN C DFAULT. THE CALLING SEQUENCE IS... C CALL IVSET(1, IV, LIV, LV, V) C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE C ENOUGH FOR IVSET, THEN IVSET SETS IV(1) TO 12. OTHERWISE IT C SETS IV(1) TO 15 OR 16. CALLING N2G WITH IV(1) = 0 CAUSES ALL C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V. C IF YOU FIRST CALL IVSET, THEN SET IV(1) TO 13 AND CALL N2G, C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR, C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV C ARE LARGE ENOUGH. IF SO, THEN N2G RETURNS WITH IV(1) = 14. C WHEN CALLED WITH IV(1) = 14, N2G ASSUMES THAT STORAGE HAS C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM. C C *** SCALE VECTOR *** C C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET C BEFORE THE ALGORITHM IS STARTED. C C *** REGRESSION DIAGNOSTICS *** C C IF IV(RDREQ) SO DICTATES, THEN ESTIMATES ARE COMPUTED OF THE C INFLUENCE EACH RESIDUAL COMPONENT HAS ON THE FINAL PARAMETER C ESTIMATE X. THE GENERAL IDEA IS THAT ONE MAY WISH TO EXAMINE C RESIDUAL COMPONENTS (AND THE DATA BEHIND THEM) FOR WHICH THE C INFLUENCE ESTIMATE IS SIGNIFICANTLY LARGER THAN MOST OF THE OTHER C INFLUENCE ESTIMATES. THESE ESTIMATES, HEREAFTER CALLED C REGRESSION DIAGNOSTICS, ARE ONLY COMPUTED IF IV(RDREQ) = 2 OR 3. C IN THIS CASE, FOR I = 1(1)N, C SQRT( G(I)**T * H(I)**-1 * G(I) ) C IS COMPUTED AND STORED IN V, STARTING AT V(IV(REGD)), WHERE C RDREQ = 57 AND REGD = 67. HERE G(I) STANDS FOR THE GRADIENT C RESULTING WHEN THE I-TH OBSERVATION IS DELETED AND H(I) STANDS C FOR AN APPROXIMATION TO THE CORRESPONDING HESSIAN AT X, THE SOLU- C TION CORRESPONDING TO ALL OBSERVATIONS. (THIS APPROXIMATION IS C OBTAINED BY SUBTRACTING THE FIRST-ORDER CONTRIBUTION OF THE I-TH C OBSERVATION TO THE HESSIAN FROM A FINITE-DIFFERENCE HESSIAN C APPROXIMATION. IF H IS INDEFINITE, THEN IV(REGD) IS SET TO -1. C IF H(I) IS INDEFINITE, THEN -1 IS RETURNED AS THE DIAGNOSTIC FOR C OBSERVATION I. IF NO DIAGNOSTICS ARE COMPUTED, PERHAPS BECAUSE C OF A FAILURE TO CONVERGE, THEN IV(REGD) = 0 IS RETURNED.) C PRINTING OF THE REGRESSION DIAGNOSTICS IS CONTROLLED BY C IV(COVPRT) = IV(14)... IF IV(COVPRT) = 3, THEN BOTH THE C COVARIANCE MATRIX AND THE REGRESSION DIAGNOSTICS ARE PRINTED. C IV(COVPRT) = 2 CAUSES ONLY THE REGRESSION DIAGNOSTICS TO BE C PRINTED, IV(COVPRT) = 1 CAUSES ONLY THE COVARIANCE MATRIX TO BE C PRINTED, AND IV(COVPRT) = 0 CAUSES NEITHER TO BE PRINTED. C C RDREQ = 57 AND REGD = 67. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RN2G, N2RDP C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RN2G... CARRIES OUT OPTIMIZATION ITERATIONS. C N2RDP... PRINTS REGRESSION DIAGNOSTICS. C C *** NO INTRINSIC FUNCTIONS *** C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED C/6 C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/, C 1 REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL RN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL RN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 60 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UI, UR, UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED C *** AND PRINT IT IF SO REQUESTED... C 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 CALL N2RDP(IV, LIV, LV, N, V(RD1), V) C 999 RETURN C C *** LAST LINE OF N2G FOLLOWS *** END SUBROUTINE N2GB(N, P, X, B, CALCR, CALCJ, IV, LIV, LV, V, 1 UIPARM, URPARM, UFPARM) C C *** VERSION OF NL2SOL THAT HANDLES SIMPLE BOUNDS ON X *** C C *** PARAMETERS *** C INTEGER N, P, LIV, LV C/6 C INTEGER IV(LIV), UIPARM(1) C REAL X(P), B(2,P), V(LV), URPARM(1) C/7 INTEGER IV(LIV), UIPARM(*) REAL X(P), B(2,P), V(LV), URPARM(*) C/ EXTERNAL CALCR, CALCJ, UFPARM C C *** DISCUSSION *** C C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383 C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, C D.M. GAY, AND R.E. WELSCH). C C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82 + 4*P. C IF NOT, THEN N2GB RETURNS WITH IV(1) = 15. WHEN N2GB C RETURNS, THE MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN C IV(LASTIV) = IV(44), (PROVIDED THAT LIV .GE. 44). C C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS C LV0 = 105 + P*(N + 2*P + 21) + 2*N. IF LV IS SMALLER THAN THIS, C THEN N2GB RETURNS WITH IV(1) = 16. WHEN N2GB RETURNS, THE C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45) C (PROVIDED LIV .GE. 45). C C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL. C C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION. C C *** BOUNDS *** C C THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P, ARE ENFORCED. C C *** DEFAULT VALUES *** C C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE IVSET, RATHER THAN C DFAULT. THE CALLING SEQUENCE IS... C CALL IVSET(1, IV, LIV, LV, V) C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE C ENOUGH FOR IVSET, THEN IVSET SETS IV(1) TO 12. OTHERWISE IT C SETS IV(1) TO 15 OR 16. CALLING N2GB WITH IV(1) = 0 CAUSES ALL C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V. C IF YOU FIRST CALL IVSET, THEN SET IV(1) TO 13 AND CALL N2GB, C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR, C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV C ARE LARGE ENOUGH. IF SO, THEN N2GB RETURNS WITH IV(1) = 14. C WHEN CALLED WITH IV(1) = 14, N2GB ASSUMES THAT STORAGE HAS C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM. C C *** SCALE VECTOR *** C C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET C BEFORE THE ALGORITHM IS STARTED. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RN2GB C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RN2GB... CARRIES OUT OPTIMIZATION ITERATIONS. C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD0, TOOBIG, VNEED C/6 C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/, C 1 REGD0/82/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD0=82, TOOBIG=2, VNEED=4) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2) CALL RN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + N IV(J) = IV(REGD0) + N IV(NEXTV) = IV(J) + N*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL RN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1), 1 V(RD1), V, X) IF (IV(1)-2) 30, 50, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C C *** LAST CARD OF N2GB FOLLOWS *** END SUBROUTINE N2LRD(DR, IV, L, LH, LIV, LV, ND, NN, P, R, RD, V) C C *** COMPUTE REGRESSION DIAGNOSTIC AND DEFAULT COVARIANCE MATRIX FOR C RN2G *** C C *** PARAMETERS *** C INTEGER LH, LIV, LV, ND, NN, P INTEGER IV(LIV) REAL DR(ND,P), L(LH), R(NN), RD(NN), V(LV) C C *** CODED BY DAVID M. GAY (WINTER 1982, FALL 1983) *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR EXTERNAL D7TPR, L7ITV, L7IVM, O7PRD, V7SCP C C *** LOCAL VARIABLES *** C INTEGER COV, I, J, M, STEP1 REAL A, FF, S, T C C *** CONSTANTS *** C REAL NEGONE, ONE, ONEV(1), ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C C *** IV AND V SUBSCRIPTS *** C INTEGER F, H, MODE, RDREQ, STEP C/6 C DATA F/10/, H/56/, MODE/35/, RDREQ/57/, STEP/40/ C/7 PARAMETER (F=10, H=56, MODE=35, RDREQ=57, STEP=40) C/ C/6 C DATA NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/ C/7 PARAMETER (NEGONE=-1.E+0, ONE=1.E+0, ZERO=0.E+0) C/ DATA ONEV(1)/1.E+0/ C C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++ C STEP1 = IV(STEP) I = IV(RDREQ) IF (I .LE. 0) GO TO 999 IF (MOD(I,4) .LT. 2) GO TO 30 FF = ONE IF (V(F) .NE. ZERO) FF = ONE / SQRT( ABS(V(F))) CALL V7SCP(NN, RD, NEGONE) DO 20 I = 1, NN A = R(I)**2 M = STEP1 DO 10 J = 1, P V(M) = DR(I,J) M = M + 1 10 CONTINUE CALL L7IVM(P, V(STEP1), L, V(STEP1)) S = D7TPR(P, V(STEP1), V(STEP1)) T = ONE - S IF (T .LE. ZERO) GO TO 20 A = A * S / T RD(I) = SQRT(A) * FF 20 CONTINUE C 30 IF (IV(MODE) - P .LT. 2) GO TO 999 C C *** COMPUTE DEFAULT COVARIANCE MATRIX *** C COV = IABS(IV(H)) DO 50 I = 1, NN M = STEP1 DO 40 J = 1, P V(M) = DR(I,J) M = M + 1 40 CONTINUE CALL L7IVM(P, V(STEP1), L, V(STEP1)) CALL L7ITV(P, V(STEP1), L, V(STEP1)) CALL O7PRD(1, LH, P, V(COV), ONEV, V(STEP1), V(STEP1)) 50 CONTINUE C 999 RETURN C *** LAST LINE OF N2LRD FOLLOWS *** END SUBROUTINE N2P(N, ND, P, X, CALCR, CALCJ, IV, LIV, LV, V, 1 UI, UR, UF) C C *** VERSION OF NL2SOL THAT CALLS RN2G AND HAS EXPANDED CALLING C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J C *** (RESIDUALS AND JACOBIAN) IN CHUNKS. C C *** PARAMETERS *** C INTEGER N, ND, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C REAL X(P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) REAL X(P), V(LV), UR(*) C/ EXTERNAL CALCR, CALCJ, UF C C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL C ON CALCR. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST C PARTIALS OF THE RESIDUAL VECTOR. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C UI...... PASSED UNCHANGED TO CALCR AND CALCJ. C UR...... PASSED UNCHANGED TO CALCR AND CALCJ. C UF...... PASSED UNCHANGED TO CALCR AND CALCJ. C C C *** DISCUSSION *** C C THIS ROUTINE IS SIMILAR TO N2G (WHICH SEE), EXCEPT THAT THE C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS. C C FOR CALCR, THE CALLING SEQUENCE IS... C C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF) C C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED C BY NL2SOL OR N2G. C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT C CHANGE ND1 OR N1 (BUT MAY CHANGE N2). C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT C CALCR SHOULD SUPPLY ON ONE CALL. C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD C SUPPLY ON THIS CALL. C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2 C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS C R(1), R(2), ..., R(N2-N1+1). C C FOR CALCJ, THE CALLING SEQUENCE IS... C C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF) C C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED, C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.) C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2 C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K). C C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, N2RDP, RN2G C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C N2RDP... PRINTS REGRESSION DIAGNOSTICS. C RN2G... CARRIES OUT OPTIMIZATION ITERATIONS. C C *** LOCAL VARIABLES *** C LOGICAL ONERD INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD0, RD1, X01 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R, RDREQ, REGD, 1 REGD0, TOOBIG, VNEED, X0 C/6 C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/, C 1 R/61/, RDREQ/57/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/, C 2 X0/43/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7, 1 R=61, RDREQ=57, REGD=67, REGD0=82, TOOBIG=2, VNEED=4, 2 X0=43) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) ND1 = MIN0(ND, N) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = IV(VNEED) + P + ND1*(P+1) ONERD = IV(RDREQ) .GE. 2 .OR. ND .GE. N IF (ONERD) I = I + N IF (IV(1) .EQ. 13) IV(VNEED) = I CALL RN2G(V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P I = IV(R) + ND1 IV(REGD0) = I IF (ONERD) I = I + N IV(J) = I IV(NEXTV) = I + ND1*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) RD0 = RD1 - 1 C 20 CALL RN2G(V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P, V(R1), 1 V(RD1), V, X) IV1 = IV(1) IF (IV1-2) 40, 30, 80 30 IF (ND .GE. N) GO TO 70 C C *** FIRST COMPUTE RELEVANT PORTION OF R *** C 40 NF = IV(NFCALL) IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL) CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 50 IV(TOOBIG) = 1 GO TO 20 50 I = IV1 + 4 GO TO (70, 60, 70, 20, 20, 70), I 60 X01 = IV(X0) CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI, 1 UR, UF) IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1 GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 RD1 = RD0 + N1 GO TO 20 C 80 RD1 = RD0 + 1 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 IF (IV(1) .LE. 8) CALL N2RDP(IV, LIV, LV, N, V(RD1), V) C 999 RETURN C C *** LAST LINE OF N2P FOLLOWS *** END SUBROUTINE N2PB(N, ND, P, X, B, CALCR, CALCJ, IV, LIV, LV, V, 1 UI, UR, UF) C C *** SIMPLY BOUNDED VERSION OF NL2SOL THAT HAS EXPANDED CALLING C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J C *** (RESIDUALS AND JACOBIAN) IN CHUNKS. C C *** PARAMETERS *** C INTEGER N, ND, P, LIV, LV C/6 C INTEGER IV(LIV), UI(1) C REAL B(2,P), X(P), V(LV), UR(1) C/7 INTEGER IV(LIV), UI(*) REAL B(2,P), X(P), V(LV), UR(*) C/ EXTERNAL CALCR, CALCJ, UF C C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL C ON CALCR. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST C PARTIALS OF THE RESIDUAL VECTOR. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C UI...... PASSED UNCHANGED TO CALCR AND CALCJ. C UR...... PASSED UNCHANGED TO CALCR AND CALCJ. C UF...... PASSED UNCHANGED TO CALCR AND CALCJ. C C C *** DISCUSSION *** C C THIS ROUTINE IS SIMILAR TO N2G (WHICH SEE), EXCEPT THAT THE C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS. C C FOR CALCR, THE CALLING SEQUENCE IS... C C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF) C C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED C BY NL2SOL OR N2G. C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT C CHANGE ND1 OR N1 (BUT MAY CHANGE N2). C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT C CALCR SHOULD SUPPLY ON ONE CALL. C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD C SUPPLY ON THIS CALL. C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2 C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS C R(1), R(2), ..., R(N2-N1+1). C C FOR CALCJ, THE CALLING SEQUENCE IS... C C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF) C C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED, C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.) C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2 C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K). C C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RN2GB C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RN2GB... CARRIES OUT OPTIMIZATION ITERATIONS. C C *** LOCAL VARIABLES *** C LOGICAL ONERD INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD1, X01 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R, 1 REGD0, TOOBIG, VNEED, X0 C/6 C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/, C 1 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/, X0/43/ C/7 PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7, 1 R=61, REGD0=82, TOOBIG=2, VNEED=4, X0=43) C/ C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) ND1 = MIN0(ND, N) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = IV(VNEED) + P + ND1*(P+1) ONERD = ND .GE. N IF (ONERD) I = I + N IF (IV(1) .EQ. 13) IV(VNEED) = I CALL RN2GB(B, V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P I = IV(R) + ND1 IV(REGD0) = I IF (ONERD) I = I + N IV(J) = I IV(NEXTV) = I + ND1*P IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL RN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P, 1 V(R1), V(RD1), V, X) IV1 = IV(1) IF (IV1-2) 40, 30, 999 30 IF (ND .GE. N) GO TO 70 C C *** FIRST COMPUTE RELEVANT PORTION OF R *** C 40 NF = IV(NFCALL) IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL) CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF) IF (NF .GT. 0) GO TO 50 IV(TOOBIG) = 1 GO TO 20 50 I = IV1 + 4 GO TO (70, 60, 70, 20, 20, 70), I 60 X01 = IV(X0) CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI, 1 UR, UF) IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1 GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C 999 RETURN C C *** LAST LINE OF N2PB FOLLOWS *** END SUBROUTINE N2RDP(IV, LIV, LV, N, RD, V) C C *** PRINT REGRESSION DIAGNOSTICS FOR MLPSL AND NL2S1 *** C INTEGER LIV, LV, N INTEGER IV(LIV) REAL RD(N), V(LV) C C *** NOTE -- V IS PASSED FOR POSSIBLE USE BY REVISED VERSIONS OF C *** THIS ROUTINE. C INTEGER PU C C *** IV AND V SUBSCRIPTS *** C INTEGER COVPRT, F, NEEDHD, PRUNIT, REGD C C/6 C DATA COVPRT/14/, F/10/, NEEDHD/36/, PRUNIT/21/, REGD/67/ C/7 PARAMETER (COVPRT=14, F=10, NEEDHD=36, PRUNIT=21, REGD=67) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (IV(COVPRT) .LT. 2) GO TO 999 IF (IV(REGD) .LE. 0) GO TO 999 IV(NEEDHD) = 1 IF (V(F)) 10, 30, 10 10 WRITE(PU,20) RD 20 FORMAT(/70H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I 1) / ABS(F) ).../(6E12.3)) GO TO 999 30 WRITE(PU,40) RD 40 FORMAT(/61H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I 1) ).../(6E12.3)) C 999 RETURN C *** LAST LINE OF N2RDP FOLLOWS *** END SUBROUTINE N7MSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT) INTEGER N,NMAX,MODE INTEGER NUM(N),INDEX(N),LAST(1),NEXT(N) C **********. C C SUBROUTINE N7MSRT C C GIVEN A SEQUENCE OF INTEGERS, THIS SUBROUTINE GROUPS C TOGETHER THOSE INDICES WITH THE SAME SEQUENCE VALUE C AND, OPTIONALLY, SORTS THE SEQUENCE INTO EITHER C ASCENDING OR DESCENDING ORDER. C C THE SEQUENCE OF INTEGERS IS DEFINED BY THE ARRAY NUM, C AND IT IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET C 0,1,...,NMAX. ON OUTPUT THE INDICES K SUCH THAT NUM(K) = L C FOR ANY L = 0,1,...,NMAX CAN BE OBTAINED FROM THE ARRAYS C LAST AND NEXT AS FOLLOWS. C C K = LAST(L+1) C WHILE (K .NE. 0) K = NEXT(K) C C OPTIONALLY, THE SUBROUTINE PRODUCES AN ARRAY INDEX SO THAT C THE SEQUENCE NUM(INDEX(I)), I = 1,2,...,N IS SORTED. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE N7MSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE. C C NMAX IS A POSITIVE INTEGER INPUT VARIABLE. C C NUM IS AN INPUT ARRAY OF LENGTH N WHICH CONTAINS THE C SEQUENCE OF INTEGERS TO BE GROUPED AND SORTED. IT C IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET C 0,1,...,NMAX. C C MODE IS AN INTEGER INPUT VARIABLE. THE SEQUENCE NUM IS C SORTED IN ASCENDING ORDER IF MODE IS POSITIVE AND IN C DESCENDING ORDER IF MODE IS NEGATIVE. IF MODE IS 0, C NO SORTING IS DONE. C C INDEX IS AN INTEGER OUTPUT ARRAY OF LENGTH N SET SO C THAT THE SEQUENCE C C NUM(INDEX(I)), I = 1,2,...,N C C IS SORTED ACCORDING TO THE SETTING OF MODE. IF MODE C IS 0, INDEX IS NOT REFERENCED. C C LAST IS AN INTEGER OUTPUT ARRAY OF LENGTH NMAX + 1. THE C INDEX OF NUM FOR THE LAST OCCURRENCE OF L IS LAST(L+1) C FOR ANY L = 0,1,...,NMAX UNLESS LAST(L+1) = 0. IN C THIS CASE L DOES NOT APPEAR IN NUM. C C NEXT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IF C NUM(K) = L, THEN THE INDEX OF NUM FOR THE PREVIOUS C OCCURRENCE OF L IS NEXT(K) FOR ANY L = 0,1,...,NMAX C UNLESS NEXT(K) = 0. IN THIS CASE THERE IS NO PREVIOUS C OCCURRENCE OF L IN NUM. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER I,J,JP,K,L,NMAXP1,NMAXP2 C C DETERMINE THE ARRAYS NEXT AND LAST. C NMAXP1 = NMAX + 1 DO 10 I = 1, NMAXP1 LAST(I) = 0 10 CONTINUE DO 20 K = 1, N L = NUM(K) NEXT(K) = LAST(L+1) LAST(L+1) = K 20 CONTINUE IF (MODE .EQ. 0) GO TO 60 C C STORE THE POINTERS TO THE SORTED ARRAY IN INDEX. C I = 1 NMAXP2 = NMAXP1 + 1 DO 50 J = 1, NMAXP1 JP = J IF (MODE .LT. 0) JP = NMAXP2 - J K = LAST(JP) 30 CONTINUE IF (K .EQ. 0) GO TO 40 INDEX(I) = K I = I + 1 K = NEXT(K) GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE RETURN C C LAST CARD OF SUBROUTINE N7MSRT. C END INTEGER FUNCTION NERROR(NERR) C C RETURNS NERROR = NERR = THE VALUE OF THE ERROR FLAG LERROR. C NERROR=I8SAVE(1,0,.FALSE.) NERR=NERROR RETURN C END INTEGER FUNCTION NIRALL(ISIZE) C CALL I0TK01 NIRALL = ISTKQU(ISIZE+2) C RETURN C END SUBROUTINE NSF(N, P, L, ALF, C, Y, CALCA, INC, IINC, IV, 1 LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING C *** FINITE-DIFFERENCE DERIVATIVES. C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C REAL ALF(P), C(L), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) REAL ALF(P), C(L), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, UFPARM C C *** PARAMETERS *** C C N (IN) NUMBER OF OBSERVATIONS. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C C (OUT) LINEAR PARAMETERS (ESTIMATED). C Y (IN) RIGHT-HAND SIDE VECTOR. C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX. C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I C OF A DEPENDS ON ALF(J). C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST C 122 + 2*M + 4*P + 2*L + MAX(L+1,6*P), WHERE M IS C THE NUMBER OF ONES IN INC. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + 2*N*(L+3) + JLEN + L*(L+3)/2 + P*(2*P + 18), C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE LAST C ROW OF INC CONTAINS ONLY ZEROS, THEN LV CAN BE 4*N C LESS THAN JUST DESCRIBED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST, C FOLLOWED BY LINEAR PARAMETERS. C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA. C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA. C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA. C C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, DSM, RNSG, V2AXY, V7CPY, V7SCL C C IVSET.... PROVIDES DEFAULT IV AND V VALUES. C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES. C RNSG... CARRIES OUT NL2SOL ALGORITHM. C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C LOGICAL PARTJ INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1, 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1, 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0, 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1 REAL DELTA, DI, H, XI REAL NEGONE, ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED, 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL, 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/, C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/, C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/, C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/, C 4 VNEED/4/, XSAVE/119/ C/7 PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43, 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111, 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47, 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2, 4 VNEED=4, XSAVE=119) C/ DATA NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C LP1 = L + 1 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 120 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 50 C C *** FRESH START *** C IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1 C C *** CHECK INC, COUNT ITS NONZEROS C L1 = 0 M = 0 DO 40 I = 1, P M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 80 40 CONTINUE C C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 *** C C *** COMPUTE STORAGE REQUIREMENTS *** C IWALEN = MAX0(LP1, 6*P) INLEN = 2 * M IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3 RSVLEN = 2 * L1 * N L1 = L + L1 IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P C 50 CALL RNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(XSAVE) = IV(DAMAT) + N*L1 IV(NEXTV) = IV(XSAVE) + P + RSVLEN IV(L1SAV) = L1 IV(MSAVE) = M C C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES C *** (SET UP TO CALL DSM) C IN1 = IV(IN) JN1 = IN1 + M DO 70 K = 1, P DO 60 I = 1, LP1 IF (INC(I,K) .EQ. 0) GO TO 60 IV(IN1) = I IN1 = IN1 + 1 IV(JN1) = K JN1 = JN1 + 1 60 CONTINUE 70 CONTINUE IN1 = IV(IN) JN1 = IN1 + M IWA1 = IN1 + INLEN NGRP1 = IWA1 + IWALEN BWA1 = NGRP1 + P IPNTR1 = BWA1 + P JPNTR1 = IPNTR1 + L + 2 CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I, 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1)) IF (I .EQ. 1) GO TO 90 IV(1) = 69 GO TO 50 80 IV(1) = 66 GO TO 50 C C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES C C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1. C 90 IV(MAXGRP) = NG IV(GPTR) = IN1 + 2*L1 GPTR1 = IV(GPTR) IV(GRP) = GPTR1 + NG + 1 IV(NEXTIV) = IV(GRP) + P GRP1 = IV(GRP) NGRP0 = NGRP1 - 1 NGRP2 = NGRP0 + P DO 110 I = 1, NG IV(GPTR1) = GRP1 GPTR1 = GPTR1 + 1 DO 100 I1 = NGRP1, NGRP2 IF (IV(I1) .NE. I) GO TO 100 IV(GRP1) = I1 - NGRP0 GRP1 = GRP1 + 1 100 CONTINUE 110 CONTINUE IV(GPTR1) = GRP1 IF (IV1 .EQ. 13) GO TO 999 C C *** INITIALIZE POINTERS *** C 120 A1 = IV(AMAT) A0 = A1 - N DA1 = IV(DAMAT) DA0 = DA1 - N IN1 = IV(IN) IN0 = IN1 - 2 L1 = IV(L1SAV) IN2 = IN1 + 2*L1 - 1 D0 = IV(D) - 1 NG = IV(MAXGRP) XSAVE1 = IV(XSAVE) XSAVE0 = XSAVE1 - 1 RSAVE1 = XSAVE1 + P RSAVE0 = RSAVE1 + N ALP1 = A1 + L*N DELTA = V(DLTFDJ) IV(COVREQ) = -IABS(IV(COVREQ)) C 130 CALL RNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV, 1 N, L1, P, V, Y) IF (IV(1)-2) 140, 150, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 140 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 IF (L1 .LE. L) GO TO 130 IF (IV(RESTOR) .EQ. 2) CALL V7CPY(N, V(RSAVE0), V(RSAVE1)) CALL V7CPY(N, V(RSAVE1), V(ALP1)) GO TO 130 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL)) 1 CALL V7CPY(N, V(RSAVE0), V(RSAVE1)) GPTR1 = IV(GPTR) DO 230 K = 1, NG CALL V7CPY(P, V(XSAVE1), ALF) GRP1 = IV(GPTR1) GRP2 = IV(GPTR1+1) - 1 GPTR1 = GPTR1 + 1 DO 160 I1 = GRP1, GRP2 I = IV(I1) XI = ALF(I) J1 = D0 + I DI = V(J1) IF (DI .LE. ZERO) DI = ONE H = DELTA * AMAX1( ABS(XI), ONE/DI) IF (XI .LT. ZERO) H = -H X0I = XSAVE0 + I V(X0I) = XI + H 160 CONTINUE CALL CALCA(N, P, L, V(XSAVE1), IV(NFGCAL), V(DA1), 1 UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .GT. 0) GO TO 170 IV(TOOBIG) = 1 GO TO 130 170 JN1 = IN1 DO 180 I = IN1, IN2 180 IV(I) = 0 PARTJ = IV(MODE) .LE. P DO 220 I1 = GRP1, GRP2 I = IV(I1) DO 210 J1 = 1, L1 IF (INC(J1,I) .EQ. 0) GO TO 210 INI = IN0 + 2*J1 IV(INI) = I IV(INI+1) = J1 X0I = XSAVE0 + I H = ONE / (V(X0I) - ALF(I)) DAJ = DA0 + J1*N IF (PARTJ) GO TO 190 C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. *** AJ = A0 + J1*N CALL V2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ)) GO TO 200 190 IF (J1 .GT. L) 1 CALL V2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ)) 200 CALL V7SCL(N, V(DAJ), H, V(DAJ)) 210 CONTINUE 220 CONTINUE IF (K .GE. NG) GO TO 240 IV(1) = -2 CALL RNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, 1 LV, N, L1, P, V, Y) IF (-2 .NE. IV(1)) GO TO 999 230 CONTINUE 240 IV(1) = 2 GO TO 130 C 999 RETURN C C *** LAST CARD OF NSF FOLLOWS *** END SUBROUTINE NSFB(N, P, L, ALF, B, C, Y, CALCA, INC, IINC, IV, 1 LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING C *** FINITE-DIFFERENCE DERIVATIVES. C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C REAL ALF(P), C(L), B(2,P), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) REAL ALF(P), C(L), B(2,P), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, UFPARM C C *** PARAMETERS *** C C N (IN) NUMBER OF OBSERVATIONS. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C B (IN) SIMBLE BOUNDS ON ALF.. B(1,I) .LE. ALF(I) .LE. B(2,I). C C (OUT) LINEAR PARAMETERS (ESTIMATED). C Y (IN) RIGHT-HAND SIDE VECTOR. C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX. C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I C OF A DEPENDS ON ALF(J). C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST C 122 + 2*M + 7*P + 2*L + MAX(L+1,6*P), WHERE M IS C THE NUMBER OF ONES IN INC. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + N*(2*L+6+P) + L*(L+3)/2 + P*(2*P + 22). C IF THE LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV C CAN BE 4*N LESS THAN JUST DESCRIBED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA. C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA. C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA. C C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, DSM, RNSGB, V2AXY, V7CPY, V7SCL C C IVSET.... PROVIDES DEFAULT IV AND V VALUES. C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES. C RNSGB... CARRIES OUT NL2SOL ALGORITHM. C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C LOGICAL PARTJ INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1, 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1, 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0, 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1 REAL DELTA, DI, H, XI, XI1 REAL NEGONE, ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED, 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL, 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/, C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/, C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/, C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/, C 4 VNEED/4/, XSAVE/119/ C/7 PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43, 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111, 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47, 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2, 4 VNEED=4, XSAVE=119) C/ DATA NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C LP1 = L + 1 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 120 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 50 C C *** FRESH START *** C IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1 C C *** CHECK INC, COUNT ITS NONZEROS C L1 = 0 M = 0 DO 40 I = 1, P IF (B(1,I) .GE. B(2,I)) GO TO 40 M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 GO TO 40 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 80 40 CONTINUE C C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 *** C C *** COMPUTE STORAGE REQUIREMENTS *** C IWALEN = MAX0(LP1, 6*P) INLEN = 2 * M IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3 RSVLEN = 2 * L1 * N L1 = L + L1 IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P C 50 CALL RNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, 1 Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(XSAVE) = IV(DAMAT) + N*L1 IV(NEXTV) = IV(XSAVE) + P + RSVLEN IV(L1SAV) = L1 IV(MSAVE) = M C C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES C *** (SET UP TO CALL DSM) C IN1 = IV(IN) JN1 = IN1 + M DO 70 K = 1, P IF (B(1,K) .GE. B(2,K)) GO TO 70 DO 60 I = 1, LP1 IF (INC(I,K) .EQ. 0) GO TO 60 IV(IN1) = I IN1 = IN1 + 1 IV(JN1) = K JN1 = JN1 + 1 60 CONTINUE 70 CONTINUE IN1 = IV(IN) JN1 = IN1 + M IWA1 = IN1 + INLEN NGRP1 = IWA1 + IWALEN BWA1 = NGRP1 + P IPNTR1 = BWA1 + P JPNTR1 = IPNTR1 + L + 2 CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I, 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1)) IF (I .EQ. 1) GO TO 90 IV(1) = 69 GO TO 50 80 IV(1) = 66 GO TO 50 C C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES C C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1. C 90 IV(MAXGRP) = NG IV(GPTR) = IN1 + 2*L1 GPTR1 = IV(GPTR) IV(GRP) = GPTR1 + NG + 1 IV(NEXTIV) = IV(GRP) + P GRP1 = IV(GRP) NGRP0 = NGRP1 - 1 NGRP2 = NGRP0 + P DO 110 I = 1, NG IV(GPTR1) = GRP1 GPTR1 = GPTR1 + 1 DO 100 I1 = NGRP1, NGRP2 IF (IV(I1) .NE. I) GO TO 100 K = I1 - NGRP0 IF (B(1,K) .GE. B(2,K)) GO TO 100 IV(GRP1) = K GRP1 = GRP1 + 1 100 CONTINUE 110 CONTINUE IV(GPTR1) = GRP1 IF (IV1 .EQ. 13) GO TO 999 C C *** INITIALIZE POINTERS *** C 120 A1 = IV(AMAT) A0 = A1 - N DA1 = IV(DAMAT) DA0 = DA1 - N IN1 = IV(IN) IN0 = IN1 - 2 L1 = IV(L1SAV) IN2 = IN1 + 2*L1 - 1 D0 = IV(D) - 1 NG = IV(MAXGRP) XSAVE1 = IV(XSAVE) XSAVE0 = XSAVE1 - 1 RSAVE1 = XSAVE1 + P RSAVE0 = RSAVE1 + N ALP1 = A1 + L*N DELTA = V(DLTFDJ) IV(COVREQ) = -IABS(IV(COVREQ)) C 130 CALL RNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, 1 LV, N, L1, P, V, Y) IF (IV(1)-2) 140, 150, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 140 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 IF (L1 .LE. L) GO TO 130 IF (IV(RESTOR) .EQ. 2) CALL V7CPY(N, V(RSAVE0), V(RSAVE1)) CALL V7CPY(N, V(RSAVE1), V(ALP1)) GO TO 130 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL)) 1 CALL V7CPY(N, V(RSAVE0), V(RSAVE1)) GPTR1 = IV(GPTR) DO 260 K = 1, NG CALL V7CPY(P, V(XSAVE1), ALF) GRP1 = IV(GPTR1) GRP2 = IV(GPTR1+1) - 1 GPTR1 = GPTR1 + 1 DO 180 I1 = GRP1, GRP2 I = IV(I1) XI = ALF(I) J1 = D0 + I DI = V(J1) IF (DI .LE. ZERO) DI = ONE H = DELTA * AMAX1( ABS(XI), ONE/DI) IF (XI .LT. ZERO) GO TO 160 XI1 = XI + H IF (XI1 .LE. B(2,I)) GO TO 170 XI1 = XI - H IF (XI1 .GE. B(1,I)) GO TO 170 GO TO 190 160 XI1 = XI - H IF (XI1 .GE. B(1,I)) GO TO 170 XI1 = XI + H IF (XI1 .LE. B(2,I)) GO TO 170 GO TO 190 170 X0I = XSAVE0 + I V(X0I) = XI1 180 CONTINUE CALL CALCA(N, P, L, V(XSAVE1), NF, V(DA1), UIPARM, URPARM, 1 UFPARM) IF (IV(NFGCAL) .GT. 0) GO TO 200 190 IV(TOOBIG) = 1 GO TO 130 200 JN1 = IN1 DO 210 I = IN1, IN2 210 IV(I) = 0 PARTJ = IV(MODE) .LE. P DO 250 I1 = GRP1, GRP2 I = IV(I1) DO 240 J1 = 1, L1 IF (INC(J1,I) .EQ. 0) GO TO 240 INI = IN0 + 2*J1 IV(INI) = I IV(INI+1) = J1 X0I = XSAVE0 + I H = ONE / (V(X0I) - ALF(I)) DAJ = DA0 + J1*N IF (PARTJ) GO TO 220 C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. *** AJ = A0 + J1*N CALL V2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ)) GO TO 230 220 IF (J1 .GT. L) 1 CALL V2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ)) 230 CALL V7SCL(N, V(DAJ), H, V(DAJ)) 240 CONTINUE 250 CONTINUE IF (K .GE. NG) GO TO 270 IV(1) = -2 CALL RNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, 1 LIV, LV, N, L1, P, V, Y) IF (-2 .NE. IV(1)) GO TO 999 260 CONTINUE 270 IV(1) = 2 GO TO 130 C 999 RETURN C C *** LAST CARD OF NSFB FOLLOWS *** END SUBROUTINE NSG(N, P, L, ALF, C, Y, CALCA, CALCB, INC, IINC, IV, 1 LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING *** C *** ANALYTICALLY COMPUTED DERIVATIVES. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C REAL ALF(P), C(L), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) REAL ALF(P), C(L), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, CALCB, UFPARM C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), NSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )). C I=1 I I C C THE (L+1)ST TERM IS OPTIONAL. C C-------------------------- PARAMETER USAGE ------------------------- C C INPUT PARAMETERS C C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)). C C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1). C C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0). C C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR C PARAMETERS. C C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW C ON THE CALLING SEQUENCE FOR CALCA. C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING C PROGRAM. C C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA- C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO C ALF -- SEE THE NOTE BELOW ON THE CALLING C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED C EXTERNAL IN THE CALLING PROGRAM. C C Y D.P. ARRAY VECTOR OF OBSERVATIONS. C C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P) C INDICATING THE POSITION OF THE NONLINEAR PARA- C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K) C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0. C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC C MUST CONTAIN AT LEAST ONE 1. C C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT C LEAST L+1. C C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS C THE ITERATION AND FUNCTION EVALUATION LIMITS AND C SWITCHES THAT CONTROL PRINTING. THE INPUT COM- C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE C PORT OPTIMIZATION DOCUMENTATION. C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A C CALL IVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS C OF IV AND V BEFORE CALLING NSG. C C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST 115+P+L + 2*M, C WHERE M IS THE NUMBER OF ONES IN INC. C C LV INTEGER LENGTH OF V. MUST BE AT LEAST C 105 + N*(L+M+3) + JLEN + L*(L+3)/2 + P*(2*P+17), C WHERE M IS AS FOR LIV (SEE ABOVE) AND C JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV C CAN BE N LESS THAN JUST DESCRIBED. C C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV C THAT CONTAINS SUCH INPUT COMPONENTS AS THE C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE C THAT V(35) CONTAINS THE INITIAL STEP BOUND, C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW. C C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C C C OUTPUT PARAMETERS C C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS. C C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO C INITIAL GUESS FOR C IS REQUIRED. C C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS C FUNCTION EVALUATION OR ITERATION LIMIT REACHED. C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A C COLUMN OF ZEROS IN INC). NOTE THAT THE C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION. C C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE C THE PORT DOCUMENTATION FOR A COMPLETE LIST. IF C A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST, C FOLLOWED BY LINEAR PARAMETERS. C C C C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM) C C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE C C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE C (L+1)ST COLUMN OF PHI. C C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS C TELLS THE ALGORITHM TO TRY A SMALLER STEP. C C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE C C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED, C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON. C C C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM) C C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA C C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC. C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE, C IF INC HAS THE FORM... C 1 1 0 C 0 1 0 C 1 0 0 C 0 0 1 C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA- C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3). C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO C ALF(3) (FOR I = 1,2,...,N). C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED. C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.) C C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T. C C------------------------------ NOTES ------------------------------- C C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671. C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RNSG C C IVSET.... PROVIDES DEFAULT IV AND V VALUES. C RNSG... CARRIES OUT NL2SOL ALGORITHM. C C *** LOCAL VARIABLES *** C INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV, 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/, C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, C 2 PERM/58/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111, 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, 2 PERM=58, TOOBIG=2, VNEED=4) C/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 90 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 60 IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1 LP1 = L + 1 L1 = 0 M = 0 DO 40 I = 1, P M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 50 40 CONTINUE C IV(IVNEED) = IV(IVNEED) + 2*M L1 = L + L1 IV(VNEED) = IV(VNEED) + N*(L1+M) GO TO 60 C 50 IV(1) = 66 C 60 CALL RNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(NEXTIV) = IV(IN) + 2*M IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(NEXTV) = IV(DAMAT) + N*M IV(L1SAV) = L1 IV(MSAVE) = M C C *** SET UP IN ARRAY *** C IN1 = IV(IN) DO 80 I = 1, P DO 70 K = 1, LP1 IF (INC(K,I) .EQ. 0) GO TO 70 IV(IN1) = I IV(IN1+1) = K IN1 = IN1 + 2 70 CONTINUE 80 CONTINUE IF (IV1 .EQ. 13) GO TO 999 C 90 A1 = IV(AMAT) DA1 = IV(DAMAT) IN1 = IV(IN) L1 = IV(L1SAV) M = IV(MSAVE) C 100 CALL RNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV, 1 N, M, P, V, Y) IF (IV(1)-2) 110, 120, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 110 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 100 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM, 1 UFPARM) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 100 C 999 RETURN C C *** LAST CARD OF NSG FOLLOWS *** END SUBROUTINE NSGB(N, P, L, ALF, B, C, Y, CALCA, CALCB, INC, IINC, 1 IV, LIV, LV, V, UIPARM, URPARM, UFPARM) C C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING *** C *** ANALYTICALLY COMPUTED DERIVATIVES. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IINC, L, LIV, LV, N, P C/6 C INTEGER INC(IINC,P), IV(LIV), UIPARM(1) C REAL ALF(P), B(2,P), C(L), URPARM(1), V(LV), Y(N) C/7 INTEGER INC(IINC,P), IV(LIV), UIPARM(*) REAL ALF(P), B(2,P), C(L), URPARM(*), V(LV), Y(N) C/ EXTERNAL CALCA, CALCB, UFPARM C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), NSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) , C I=1 I I C C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS C B(1,I) .LE. ALF(I) .LE. B(2,I), C I = 1(1)P. C C THE (L+1)ST TERM IS OPTIONAL. C C-------------------------- PARAMETER USAGE ------------------------- C C INPUT PARAMETERS C C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)). C C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1). C C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0). C C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR C PARAMETERS. C C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW C ON THE CALLING SEQUENCE FOR CALCA. C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING C PROGRAM. C C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA- C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO C ALF -- SEE THE NOTE BELOW ON THE CALLING C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED C EXTERNAL IN THE CALLING PROGRAM. C C Y D.P. ARRAY VECTOR OF OBSERVATIONS. C C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P) C INDICATING THE POSITION OF THE NONLINEAR PARA- C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K) C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0. C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC C MUST CONTAIN AT LEAST ONE 1. C C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT C LEAST L+1. C C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS C THE ITERATION AND FUNCTION EVALUATION LIMITS AND C SWITCHES THAT CONTROL PRINTING. THE INPUT COM- C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE C PORT OPTIMIZATION DOCUMENTATION. C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A C CALL IVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS C OF IV AND V BEFORE CALLING NSGB. C C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST C 115 + 4*P + L + 2*M, C WHERE M IS THE NUMBER OF ONES IN INC. C C LV INTEGER LENGTH OF V. MUST BE AT LEAST C 105 + N*(L+M+P+3) + L*(L+3)/2 + P*(2*P+21), C WHERE M IS AS FOR LIV (SEE ABOVE). IF THE C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV C CAN BE N LESS THAN JUST DESCRIBED. C C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV C THAT CONTAINS SUCH INPUT COMPONENTS AS THE C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE C THAT V(35) CONTAINS THE INITIAL STEP BOUND, C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW. C C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION C TO CALCA AND CALCB. C C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C C C OUTPUT PARAMETERS C C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS. C C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO C INITIAL GUESS FOR C IS REQUIRED. C C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS C FUNCTION EVALUATION OR ITERATION LIMIT REACHED. C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A C COLUMN OF ZEROS IN INC). NOTE THAT THE C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION. C C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE C THE PORT DOCUMENTATION FOR A COMPLETE LIST. C C C C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM) C C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE C C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE C (L+1)ST COLUMN OF PHI. C C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS C TELLS THE ALGORITHM TO TRY A SMALLER STEP. C C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE C C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED, C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON. C C C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM) C C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA C C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC. C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE, C IF INC HAS THE FORM... C 1 1 0 C 0 1 0 C 1 0 0 C 0 0 1 C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA- C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3). C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO C ALF(3) (FOR I = 1,2,...,N). C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED. C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.) C C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T. C C------------------------------ NOTES ------------------------------- C C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671. C C-------------------------- DECLARATIONS ---------------------------- C C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RNSGB C C IVSET.... PROVIDES DEFAULT IV AND V VALUES. C RNSGB... CARRIES OUT NL2SOL ALGORITHM. C C *** LOCAL VARIABLES *** C INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV, 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/, C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, C 2 PERM/58/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111, 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, 2 PERM=58, TOOBIG=2, VNEED=4) C/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 90 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 60 IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1 LP1 = L + 1 L1 = 0 M = 0 DO 40 I = 1, P M0 = M IF (L .EQ. 0) GO TO 20 DO 10 K = 1, L IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50 IF (INC(K,I) .EQ. 1) M = M + 1 10 CONTINUE 20 IF (INC(LP1,I) .NE. 1) GO TO 30 M = M + 1 L1 = 1 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0 1 .OR. INC(LP1,I) .GT. 1) GO TO 50 40 CONTINUE C IV(IVNEED) = IV(IVNEED) + 2*M L1 = L + L1 IV(VNEED) = IV(VNEED) + N*(L1+M) GO TO 60 C 50 IV(1) = 66 C 60 CALL RNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, 1 Y) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IN) = IV(NEXTIV) IV(NEXTIV) = IV(IN) + 2*M IV(AMAT) = IV(NEXTV) IV(DAMAT) = IV(AMAT) + N*L1 IV(NEXTV) = IV(DAMAT) + N*M IV(L1SAV) = L1 IV(MSAVE) = M C C *** SET UP IN ARRAY *** C IN1 = IV(IN) DO 80 I = 1, P DO 70 K = 1, LP1 IF (INC(K,I) .EQ. 0) GO TO 70 IV(IN1) = I IV(IN1+1) = K IN1 = IN1 + 2 70 CONTINUE 80 CONTINUE IF (IV1 .EQ. 13) GO TO 999 C 90 A1 = IV(AMAT) DA1 = IV(DAMAT) IN1 = IV(IN) L1 = IV(L1SAV) M = IV(MSAVE) C 100 CALL RNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, 1 LV, N, M, P, V, Y) IF (IV(1)-2) 110, 120, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 110 NF = IV(NFCALL) CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM) IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 100 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM, 1 UFPARM) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 100 C 999 RETURN C C *** LAST CARD OF NSGB FOLLOWS *** END SUBROUTINE O7PRD(L, LS, P, S, W, Y, Z) C C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E., C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I). C INTEGER L, LS, P REAL S(LS), W(L), Y(P,L), Z(P,L) C DIMENSION S(P*(P+1)/2) C INTEGER I, J, K, M REAL WK, YI, ZERO DATA ZERO/0.E+0/ C DO 30 K = 1, L WK = W(K) IF (WK .EQ. ZERO) GO TO 30 M = 1 DO 20 I = 1, P YI = WK * Y(I,K) DO 10 J = 1, I S(M) = S(M) + YI*Z(J,K) M = M + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE C 999 RETURN C *** LAST CARD OF O7PRD FOLLOWS *** END SUBROUTINE ORTHE(NM,N,LOW,IGH,A,ORT) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL A(NM,N),ORT(IGH) REAL F,G,H,SCALE REAL SQRT,ABS,SIGN C C THIS IS THE EISPACK ROUTINE, ORTHES, PUT INTO PORT C AUGUST 18, 1976. C C THE NAME CHANGE IS DUE TO THE PORT CONVENTION THAT ALL DOUBLE C PRECISION NAMES HAVE A D PUT IN FRONT OF THE SINGLE-PRECISION C ONES, WHICH THEREFORE HAVE TO HAVE ONLY 5 CHARACTERS. C C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT- C C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLE UNDER THE C HESSENBERG MATRIX, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ------------------------------------------------------------------ C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.0 ORT(M) = 0.0 SCALE = 0.0 C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ********** DO 90 I = M, IGH 90 SCALE = SCALE + ABS(A(I,M-1)) C IF (SCALE .EQ. 0.0) GO TO 180 MP = M + IGH C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 100 II = M, IGH I = MP - II ORT(I) = A(I,M-1) / SCALE H = H + ORT(I) * ORT(I) 100 CONTINUE C G = -SIGN(SQRT(H),ORT(M)) H = H - ORT(M) * G ORT(M) = ORT(M) - G C ********** FORM (I-(U*UT)/H) * A ********** DO 130 J = M, N F = 0.0 C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 110 II = M, IGH I = MP - II F = F + ORT(I) * A(I,J) 110 CONTINUE C F = F / H C DO 120 I = M, IGH 120 A(I,J) = A(I,J) - F * ORT(I) C 130 CONTINUE C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ********** DO 160 I = 1, IGH F = 0.0 C ********** FOR J=IGH STEP -1 UNTIL M DO -- ********** DO 140 JJ = M, IGH J = MP - JJ F = F + ORT(J) * A(I,J) 140 CONTINUE C F = F / H C DO 150 J = M, IGH 150 A(I,J) = A(I,J) - F * ORT(J) C 160 CONTINUE C ORT(M) = SCALE * ORT(M) A(M,M-1) = SCALE * G 180 CONTINUE C 200 RETURN C ********** LAST CARD OF ORTHE ********** END SUBROUTINE ORTRA(NM,N,LOW,IGH,A,ORT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,IGH),ORT(IGH),Z(NM,N) REAL G C C THIS IS THE EISPACK ROUTINE, ORTRAN, PUT INTO PORT C AUGUST 18, 1976. C C THE NAME CHANGE IS DUE TO THE PORT CONVENTION THAT ALL DOUBLE C PRECISION NAMES HAVE A D PUT IN FRONT OF THE SINGLE- C PRECISION ONES, WHICH THEREFORE CAN HAVE ONLY 5 CHARACTERS. C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL C MATRIX TO UPPER HESSENBERG FORM BY ORTHE. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION BY ORTHE C IN ITS STRICT LOWER TRIANGLE, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- C FORMATIONS USED IN THE REDUCTION BY ORTHE. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY ORTHE, C C ORT HAS BEEN ALTERED. C C ------------------------------------------------------------------ C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0 C Z(I,I) = 1.0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHE. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN C ********** LAST CARD OF ORTRA ********** END SUBROUTINE PARCK(ALG, D, IV, LIV, LV, N, V) C C *** CHECK ***SOL (VERSION 2.3) PARAMETERS, PRINT CHANGED VALUES *** C C *** ALG = 1 FOR REGRESSION, ALG = 2 FOR GENERAL UNCONSTRAINED OPT. C INTEGER ALG, LIV, LV, N INTEGER IV(LIV) REAL D(N), V(LV) C REAL R7MDC EXTERNAL IVSET, R7MDC, V7CPY, V7DFL C IVSET -- SUPPLIES DEFAULT VALUES TO BOTH IV AND V. C R7MDC -- RETURNS MACHINE-DEPENDENT CONSTANTS. C V7CPY -- COPIES ONE VECTOR TO ANOTHER. C V7DFL -- SUPPLIES DEFAULT PARAMETER VALUES TO V ALONE. C C *** LOCAL VARIABLES *** C INTEGER ALG1, I, II, IV1, J, K, L, M, MIV1, MIV2, NDFALT, PARSV1, 1 PU INTEGER IJMP, JLIM(4), MINIV(4), NDFLT(4) C/6S C INTEGER VARNM(2), SH(2) C REAL CNGD(3), DFLT(3), VN(2,34), WHICH(3) C/7S CHARACTER*1 VARNM(2), SH(2) CHARACTER*4 CNGD(3), DFLT(3), VN(2,34), WHICH(3) C/ REAL BIG, MACHEP, TINY, VK, VM(34), VX(34), ZERO C C *** IV AND V SUBSCRIPTS *** C INTEGER ALGSAV, DINIT, DTYPE, DTYPE0, EPSLON, INITS, IVNEED, 1 LASTIV, LASTV, LMAT, NEXTIV, NEXTV, NVDFLT, OLDN, 2 PARPRT, PARSAV, PERM, PRUNIT, VNEED C C C/6 C DATA ALGSAV/51/, DINIT/38/, DTYPE/16/, DTYPE0/54/, EPSLON/19/, C 1 INITS/25/, IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/, C 2 NEXTIV/46/, NEXTV/47/, NVDFLT/50/, OLDN/38/, PARPRT/20/, C 3 PARSAV/49/, PERM/58/, PRUNIT/21/, VNEED/4/ C/7 PARAMETER (ALGSAV=51, DINIT=38, DTYPE=16, DTYPE0=54, EPSLON=19, 1 INITS=25, IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, 2 NEXTIV=46, NEXTV=47, NVDFLT=50, OLDN=38, PARPRT=20, 3 PARSAV=49, PERM=58, PRUNIT=21, VNEED=4) SAVE BIG, MACHEP, TINY C/ C DATA BIG/0.E+0/, MACHEP/-1.E+0/, TINY/1.E+0/, ZERO/0.E+0/ C/6S C DATA VN(1,1),VN(2,1)/4HEPSL,4HON../ C DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../ C DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../ C DATA VN(1,4),VN(2,4)/4HDECF,4HAC../ C DATA VN(1,5),VN(2,5)/4HINCF,4HAC../ C DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../ C DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../ C DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../ C DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../ C DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../ C DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../ C DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../ C DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../ C DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../ C DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../ C DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../ C DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../ C DATA VN(1,18),VN(2,18)/4HLMAX,4HS.../ C DATA VN(1,19),VN(2,19)/4HSCTO,4HL.../ C DATA VN(1,20),VN(2,20)/4HDINI,4HT.../ C DATA VN(1,21),VN(2,21)/4HDTIN,4HIT../ C DATA VN(1,22),VN(2,22)/4HD0IN,4HIT../ C DATA VN(1,23),VN(2,23)/4HDFAC,4H..../ C DATA VN(1,24),VN(2,24)/4HDLTF,4HDC../ C DATA VN(1,25),VN(2,25)/4HDLTF,4HDJ../ C DATA VN(1,26),VN(2,26)/4HDELT,4HA0../ C DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../ C DATA VN(1,28),VN(2,28)/4HRLIM,4HIT../ C DATA VN(1,29),VN(2,29)/4HCOSM,4HIN../ C DATA VN(1,30),VN(2,30)/4HHUBE,4HRC../ C DATA VN(1,31),VN(2,31)/4HRSPT,4HOL../ C DATA VN(1,32),VN(2,32)/4HSIGM,4HIN../ C DATA VN(1,33),VN(2,33)/4HETA0,4H..../ C DATA VN(1,34),VN(2,34)/4HBIAS,4H..../ C/7S DATA VN(1,1),VN(2,1)/'EPSL','ON..'/ DATA VN(1,2),VN(2,2)/'PHMN','FC..'/ DATA VN(1,3),VN(2,3)/'PHMX','FC..'/ DATA VN(1,4),VN(2,4)/'DECF','AC..'/ DATA VN(1,5),VN(2,5)/'INCF','AC..'/ DATA VN(1,6),VN(2,6)/'RDFC','MN..'/ DATA VN(1,7),VN(2,7)/'RDFC','MX..'/ DATA VN(1,8),VN(2,8)/'TUNE','R1..'/ DATA VN(1,9),VN(2,9)/'TUNE','R2..'/ DATA VN(1,10),VN(2,10)/'TUNE','R3..'/ DATA VN(1,11),VN(2,11)/'TUNE','R4..'/ DATA VN(1,12),VN(2,12)/'TUNE','R5..'/ DATA VN(1,13),VN(2,13)/'AFCT','OL..'/ DATA VN(1,14),VN(2,14)/'RFCT','OL..'/ DATA VN(1,15),VN(2,15)/'XCTO','L...'/ DATA VN(1,16),VN(2,16)/'XFTO','L...'/ DATA VN(1,17),VN(2,17)/'LMAX','0...'/ DATA VN(1,18),VN(2,18)/'LMAX','S...'/ DATA VN(1,19),VN(2,19)/'SCTO','L...'/ DATA VN(1,20),VN(2,20)/'DINI','T...'/ DATA VN(1,21),VN(2,21)/'DTIN','IT..'/ DATA VN(1,22),VN(2,22)/'D0IN','IT..'/ DATA VN(1,23),VN(2,23)/'DFAC','....'/ DATA VN(1,24),VN(2,24)/'DLTF','DC..'/ DATA VN(1,25),VN(2,25)/'DLTF','DJ..'/ DATA VN(1,26),VN(2,26)/'DELT','A0..'/ DATA VN(1,27),VN(2,27)/'FUZZ','....'/ DATA VN(1,28),VN(2,28)/'RLIM','IT..'/ DATA VN(1,29),VN(2,29)/'COSM','IN..'/ DATA VN(1,30),VN(2,30)/'HUBE','RC..'/ DATA VN(1,31),VN(2,31)/'RSPT','OL..'/ DATA VN(1,32),VN(2,32)/'SIGM','IN..'/ DATA VN(1,33),VN(2,33)/'ETA0','....'/ DATA VN(1,34),VN(2,34)/'BIAS','....'/ C/ C DATA VM(1)/1.0E-3/, VM(2)/-0.99E+0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/, 1 VM(5)/1.2E+0/, VM(6)/1.E-2/, VM(7)/1.2E+0/, VM(8)/0.E+0/, 2 VM(9)/0.E+0/, VM(10)/1.E-3/, VM(11)/-1.E+0/, VM(13)/0.E+0/, 3 VM(15)/0.E+0/, VM(16)/0.E+0/, VM(19)/0.E+0/, VM(20)/-10.E+0/, 4 VM(21)/0.E+0/, VM(22)/0.E+0/, VM(23)/0.E+0/, VM(27)/1.01E+0/, 5 VM(28)/1.E+10/, VM(30)/0.E+0/, VM(31)/0.E+0/, VM(32)/0.E+0/, 6 VM(34)/0.E+0/ DATA VX(1)/0.9E+0/, VX(2)/-1.E-3/, VX(3)/1.E+1/, VX(4)/0.8E+0/, 1 VX(5)/1.E+2/, VX(6)/0.8E+0/, VX(7)/1.E+2/, VX(8)/0.5E+0/, 2 VX(9)/0.5E+0/, VX(10)/1.E+0/, VX(11)/1.E+0/, VX(14)/0.1E+0/, 3 VX(15)/1.E+0/, VX(16)/1.E+0/, VX(19)/1.E+0/, VX(23)/1.E+0/, 4 VX(24)/1.E+0/, VX(25)/1.E+0/, VX(26)/1.E+0/, VX(27)/1.E+10/, 5 VX(29)/1.E+0/, VX(31)/1.E+0/, VX(32)/1.E+0/, VX(33)/1.E+0/, 6 VX(34)/1.E+0/ C C/6S C DATA VARNM(1)/1HP/, VARNM(2)/1HP/, SH(1)/1HS/, SH(2)/1HH/ C DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/, C 1 DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/ C/7S DATA VARNM(1)/'P'/, VARNM(2)/'P'/, SH(1)/'S'/, SH(2)/'H'/ DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ C/ DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/, 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/ C C............................... BODY ................................ C PU = 0 IF (PRUNIT .LE. LIV) PU = IV(PRUNIT) IF (ALGSAV .GT. LIV) GO TO 20 IF (ALG .EQ. IV(ALGSAV)) GO TO 20 IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV) 10 FORMAT(/40H THE FIRST PARAMETER TO IVSET SHOULD BE,I3, 1 12H RATHER THAN,I3) IV(1) = 67 GO TO 999 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340 MIV1 = MINIV(ALG) IF (IV(1) .EQ. 15) GO TO 360 ALG1 = MOD(ALG-1,2) + 1 IF (IV(1) .EQ. 0) CALL IVSET(ALG, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30 IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1) IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2 IF (LIV .LT. MIV1) GO TO 300 IV(IVNEED) = 0 IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1 IV(VNEED) = 0 IF (LIV .LT. MIV2) GO TO 300 IF (LV .LT. IV(LASTV)) GO TO 320 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60 IF (N .GE. 1) GO TO 50 IV(1) = 81 IF (PU .EQ. 0) GO TO 999 WRITE(PU,40) VARNM(ALG1), N 40 FORMAT(/8H /// BAD,A1,2H =,I5) GO TO 999 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM) IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT) IF (IV1 .EQ. 13) GO TO 999 K = IV(PARSAV) - EPSLON CALL V7DFL(ALG1, LV-K, V(K+1)) IV(DTYPE0) = 2 - ALG1 IV(OLDN) = N WHICH(1) = DFLT(1) WHICH(2) = DFLT(2) WHICH(3) = DFLT(3) GO TO 110 60 IF (N .EQ. IV(OLDN)) GO TO 80 IV(1) = 17 IF (PU .EQ. 0) GO TO 999 WRITE(PU,70) VARNM(ALG1), IV(OLDN), N 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5) GO TO 999 C 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100 IV(1) = 80 IF (PU .NE. 0) WRITE(PU,90) IV1 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.) GO TO 999 C 100 WHICH(1) = CNGD(1) WHICH(2) = CNGD(2) WHICH(3) = CNGD(3) C 110 IF (IV1 .EQ. 14) IV1 = 12 IF (BIG .GT. TINY) GO TO 120 TINY = R7MDC(1) MACHEP = R7MDC(3) BIG = R7MDC(6) VM(12) = MACHEP VX(12) = BIG VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = TINY VX(18) = BIG VX(20) = BIG VX(21) = BIG VX(22) = BIG VM(24) = MACHEP VM(25) = MACHEP VM(26) = MACHEP VX(28) = R7MDC(5) VM(29) = MACHEP VX(30) = BIG VM(33) = MACHEP 120 M = 0 I = 1 J = JLIM(ALG1) K = EPSLON NDFALT = NDFLT(ALG1) DO 150 L = 1, NDFALT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140 M = K IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK, 1 VM(I), VX(I) 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,E11.3,7H SHOULD, 1 11H BE BETWEEN,E11.3,4H AND,E11.3) 140 K = K + 1 I = I + 1 IF (I .EQ. J) I = IJMP 150 CONTINUE C IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170 IV(1) = 51 IF (PU .EQ. 0) GO TO 999 WRITE(PU,160) IV(NVDFLT), NDFALT 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5) GO TO 999 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12) 1 GO TO 200 DO 190 I = 1, N IF (D(I) .GT. ZERO) GO TO 190 M = 18 IF (PU .NE. 0) WRITE(PU,180) I, D(I) 180 FORMAT(/8H /// D(,I3,3H) =,E11.3,19H SHOULD BE POSITIVE) 190 CONTINUE 200 IF (M .EQ. 0) GO TO 210 IV(1) = M GO TO 999 C 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230 M = 1 WRITE(PU,220) SH(ALG1), IV(INITS) 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =, 1 I3) 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250 IF (M .EQ. 0) WRITE(PU,260) WHICH M = 1 WRITE(PU,240) IV(DTYPE) 240 FORMAT(20H DTYPE..... IV(16) =,I3) 250 I = 1 J = JLIM(ALG1) K = EPSLON L = IV(PARSAV) NDFALT = NDFLT(ALG1) DO 290 II = 1, NDFALT IF (V(K) .EQ. V(L)) GO TO 280 IF (M .EQ. 0) WRITE(PU,260) WHICH 260 FORMAT(/1H ,3A4,9HALUES..../) M = 1 WRITE(PU,270) VN(1,I), VN(2,I), K, V(K) 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,E15.7) 280 K = K + 1 L = L + 1 I = I + 1 IF (I .EQ. J) I = IJMP 290 CONTINUE C IV(DTYPE0) = IV(DTYPE) PARSV1 = IV(PARSAV) CALL V7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON)) GO TO 999 C 300 IV(1) = 15 IF (PU .EQ. 0) GO TO 999 WRITE(PU,310) LIV, MIV2 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5) IF (LIV .LT. MIV1) GO TO 999 IF (LV .LT. IV(LASTV)) GO TO 320 GO TO 999 C 320 IV(1) = 16 IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV) 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5) GO TO 999 C 340 IV(1) = 67 IF (PU .NE. 0) WRITE(PU,350) ALG 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4) GO TO 999 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5, 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1 IF (LASTV .LE. LIV) IV(LASTV) = 0 C 999 RETURN C *** LAST LINE OF PARCK FOLLOWS *** END SUBROUTINE Q7APL(NN, N, P, J, R, IERR) C *****PARAMETERS. INTEGER NN, N, P, IERR REAL J(NN,P), R(N) C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS C STORED IN J BY QRFACT C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN C THE CALLING PROGRAM DIMENSION STATEMENT C C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R C C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA C C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C IDENT - U*U.TRANSPOSE C C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL C TRANSFORMATIONS WILL BE APPLIED C C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED C C ON OUTPUT. C C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE C C *****APPLICATION AND USAGE RESTRICTIONS. C NONE C C *****ALGORITHM NOTES. C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE USE OF C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1). C C *****SUBROUTINES AND FUNCTIONS CALLED. C C D7TPR - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS C C *****REFERENCES. C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7, C PP. 269-276. C C *****HISTORY. C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977) C CALL ON V2AXY SUBSTITUTED FOR DO LOOP, FALL 1983. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *****LOCAL VARIABLES. INTEGER K, L, NL1 C *****FUNCTIONS. REAL D7TPR EXTERNAL D7TPR, V2AXY C C *** BODY *** C K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 IF ( K .EQ. 0) GO TO 999 C DO 20 L = 1, K NL1 = N - L + 1 CALL V2AXY(NL1, R(L), - D7TPR(NL1,J(L,L),R(L)), J(L,L), R(L)) 20 CONTINUE C 999 RETURN C *** LAST LINE OF Q7APL FOLLOWS *** END SUBROUTINE Q7RAD(N, NN, P, QTR, QTRSET, RMAT, W, Y) C C *** ADD ROWS W TO QR FACTORIZATION WITH R MATRIX RMAT AND C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENTS OF RESIDUAL C *** CORRESPONDING TO W. QTR, Y REFERENCED ONLY IF QTRSET = .TRUE. C LOGICAL QTRSET INTEGER N, NN, P REAL QTR(P), RMAT(1), W(NN,P), Y(N) C DIMENSION RMAT(P*(P+1)/2) C/+ REAL SQRT C/ REAL D7TPR, R7MDC, V2NRM EXTERNAL D7TPR, R7MDC, V2AXY, V7SCL, V2NRM C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IP1, J, K, NK REAL ARI, QRI, RI, S, T, WI REAL BIG, BIGRT, ONE, TINY, TINYRT, ZERO C/7 SAVE BIGRT, TINY, TINYRT C/ DATA BIG/-1.E+0/, BIGRT/-1.E+0/, ONE/1.E+0/, TINY/0.E+0/, 1 TINYRT/0.E+0/, ZERO/0.E+0/ C C------------------------------ BODY ----------------------------------- C IF (TINY .GT. ZERO) GO TO 10 TINY = R7MDC(1) BIG = R7MDC(6) IF (TINY*BIG .LT. ONE) TINY = ONE / BIG 10 K = 1 NK = N II = 0 DO 180 I = 1, P II = II + I IP1 = I + 1 IJ = II + I IF (NK .LE. 1) T = ABS(W(K,I)) IF (NK .GT. 1) T = V2NRM(NK, W(K,I)) IF (T .LT. TINY) GOTO 180 RI = RMAT(II) IF (RI .NE. ZERO) GO TO 100 IF (NK .GT. 1) GO TO 30 IJ = II DO 20 J = I, P RMAT(IJ) = W(K,J) IJ = IJ + J 20 CONTINUE IF (QTRSET) QTR(I) = Y(K) W(K,I) = ZERO GO TO 999 30 WI = W(K,I) IF (BIGRT .GT. ZERO) GO TO 40 BIGRT = R7MDC(5) TINYRT = R7MDC(2) 40 IF (T .LE. TINYRT) GO TO 50 IF (T .GE. BIGRT) GO TO 50 IF (WI .LT. ZERO) T = -T WI = WI + T S = SQRT(T * WI) GO TO 70 50 S = SQRT(T) IF (WI .LT. ZERO) GO TO 60 WI = WI + T S = S * SQRT(WI) GO TO 70 60 T = -T WI = WI + T S = S * SQRT(-WI) 70 W(K,I) = WI CALL V7SCL(NK, W(K,I), ONE/S, W(K,I)) RMAT(II) = -T IF (.NOT. QTRSET) GO TO 80 CALL V2AXY(NK, Y(K), - D7TPR(NK,Y(K),W(K,I)), W(K,I), Y(K)) QTR(I) = Y(K) 80 IF (IP1 .GT. P) GO TO 999 DO 90 J = IP1, P CALL V2AXY(NK, W(K,J), - D7TPR(NK,W(K,J),W(K,I)), 1 W(K,I), W(K,J)) RMAT(IJ) = W(K,J) IJ = IJ + J 90 CONTINUE IF (NK .LE. 1) GO TO 999 K = K + 1 NK = NK - 1 GO TO 180 C 100 ARI = ABS(RI) IF (ARI .GT. T) GO TO 110 T = T * SQRT(ONE + (ARI/T)**2) GO TO 120 110 T = ARI * SQRT(ONE + (T/ARI)**2) 120 IF (RI .LT. ZERO) T = -T RI = RI + T RMAT(II) = -T S = -RI / T IF (NK .LE. 1) GO TO 150 CALL V7SCL(NK, W(K,I), ONE/RI, W(K,I)) IF (.NOT. QTRSET) GO TO 130 QRI = QTR(I) T = S * ( QRI + D7TPR(NK, Y(K), W(K,I)) ) QTR(I) = QRI + T 130 IF (IP1 .GT. P) GO TO 999 IF (QTRSET) CALL V2AXY(NK, Y(K), T, W(K,I), Y(K)) DO 140 J = IP1, P RI = RMAT(IJ) T = S * ( RI + D7TPR(NK, W(K,J), W(K,I)) ) CALL V2AXY(NK, W(K,J), T, W(K,I), W(K,J)) RMAT(IJ) = RI + T IJ = IJ + J 140 CONTINUE GO TO 180 C 150 WI = W(K,I) / RI W(K,I) = WI IF (.NOT. QTRSET) GO TO 160 QRI = QTR(I) T = S * ( QRI + Y(K)*WI ) QTR(I) = QRI + T 160 IF (IP1 .GT. P) GO TO 999 IF (QTRSET) Y(K) = T*WI + Y(K) DO 170 J = IP1, P RI = RMAT(IJ) T = S * (RI + W(K,J)*WI) W(K,J) = W(K,J) + T*WI RMAT(IJ) = RI + T IJ = IJ + J 170 CONTINUE 180 CONTINUE C 999 RETURN C *** LAST LINE OF Q7RAD FOLLOWS *** END SUBROUTINE Q7RFH(IERR, IPIVOT, N, NN, NOPIVK, P, Q, R, RLEN, W) C C *** COMPUTE QR FACTORIZATION VIA HOUSEHOLDER TRANSFORMATIONS C *** WITH COLUMN PIVOTING *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, N, NN, NOPIVK, P, RLEN INTEGER IPIVOT(P) REAL Q(NN,P), R(RLEN), W(P) C DIMENSION R(P*(P+1)/2) C C---------------------------- DESCRIPTION ---------------------------- C C THIS ROUTINE COMPUTES A QR FACTORIZATION (VIA HOUSEHOLDER TRANS- C FORMATIONS) OF THE MATRIX A THAT ON INPUT IS STORED IN Q. C IF NOPIVK ALLOWS IT, THIS ROUTINE DOES COLUMN PIVOTING -- IF C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING. C THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF Q*R EQUALS C COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UPPER TRIANGULAR C MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., THE OUTPUT VECTOR R C CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), R(2,3), ..., R(P,P) (IN C THAT ORDER). IF ALL GOES WELL, THEN THIS ROUTINE SETS IERR = 0. C BUT IF (PERMUTED) COLUMN K OF A IS LINEARLY DEPENDENT ON C (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR IS SET TO K AND THE R C MATRIX RETURNED HAS R(I,J) = 0 FOR I .GE. K AND J .GE. K. C THE ORIGINAL MATRIX A IS AN N BY P MATRIX. NN IS THE LEAD C DIMENSION OF THE ARRAY Q AND MUST SATISFY NN .GE. N. NO C PARAMETER CHECKING IS DONE. C PIVOTING IS DONE AS THOUGH ALL COLUMNS OF Q WERE FIRST C SCALED TO HAVE THE SAME NORM. IF COLUMN K IS ELIGIBLE FOR C PIVOTING AND ITS (SCALED) NORM**2 LOSS IS MORE THAN THE C MINIMUM SUCH LOSS (OVER COLUMNS K THRU P), THEN COLUMN K IS C SWAPPED WITH THE COLUMN OF LEAST NORM**2 LOSS. C C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984). C C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I, II, J, K, KK, KM1, KP1, NK1 REAL AK, QKK, S, SINGTL, T, T1, WK REAL D7TPR, R7MDC, V2NRM EXTERNAL D7TPR, R7MDC, V2AXY, V7SCL, V7SCP, V7SWP, V2NRM C/+ REAL SQRT C/ REAL BIG, BIGRT, MEPS10, ONE, TEN, TINY, TINYRT, 1 WTOL, ZERO C/6 C DATA ONE/1.0E+0/, TEN/1.E+1/, WTOL/0.75E+0/, ZERO/0.0E+0/ C/7 PARAMETER (ONE=1.0E+0, TEN=1.E+1, WTOL=0.75E+0, ZERO=0.0E+0) SAVE BIGRT, MEPS10, TINY, TINYRT C/ DATA BIGRT/0.0E+0/, MEPS10/0.0E+0/, TINY/0.E+0/, TINYRT/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IERR = 0 IF (MEPS10 .GT. ZERO) GO TO 10 BIGRT = R7MDC(5) MEPS10 = TEN * R7MDC(3) TINYRT = R7MDC(2) TINY = R7MDC(1) BIG = R7MDC(6) IF (TINY*BIG .LT. ONE) TINY = ONE / BIG 10 SINGTL = FLOAT(MAX0(N,P)) * MEPS10 C C *** INITIALIZE W, IPIVOT, AND DIAG(R) *** C J = 0 DO 40 I = 1, P IPIVOT(I) = I T = V2NRM(N, Q(1,I)) IF (T .GT. ZERO) GO TO 20 W(I) = ONE GO TO 30 20 W(I) = ZERO 30 J = J + I R(J) = T 40 CONTINUE C C *** MAIN LOOP *** C KK = 0 NK1 = N + 1 DO 130 K = 1, P IF (NK1 .LE. 1) GO TO 999 NK1 = NK1 - 1 KK = KK + K KP1 = K + 1 IF (K .LE. NOPIVK) GO TO 60 IF (K .GE. P) GO TO 60 C C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS *** C T = W(K) IF (T .LE. ZERO) GO TO 60 J = K DO 50 I = KP1, P IF (W(I) .GE. T) GO TO 50 T = W(I) J = I 50 CONTINUE IF (J .EQ. K) GO TO 60 C C *** INTERCHANGE COLUMNS K AND J *** C I = IPIVOT(K) IPIVOT(K) = IPIVOT(J) IPIVOT(J) = I W(J) = W(K) W(K) = T I = J*(J+1)/2 T1 = R(I) R(I) = R(KK) R(KK) = T1 CALL V7SWP(N, Q(1,K), Q(1,J)) IF (K .LE. 1) GO TO 60 I = I - J + 1 J = KK - K + 1 CALL V7SWP(K-1, R(I), R(J)) C C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE C *** WHETHER TO REORTHOGONALIZE IT. C 60 AK = R(KK) IF (AK .LE. ZERO) GO TO 140 WK = W(K) C C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K)) C *** AND CHECK FOR SINGULARITY. C IF (WK .LT. WTOL) GO TO 70 T = V2NRM(NK1, Q(K,K)) IF (T / AK .LE. SINGTL) GO TO 140 GO TO 80 70 T = SQRT(ONE - WK) IF (T .LE. SINGTL) GO TO 140 T = T * AK C C *** DETERMINE HOUSEHOLDER TRANSFORMATION *** C 80 QKK = Q(K,K) IF (T .LE. TINYRT) GO TO 90 IF (T .GE. BIGRT) GO TO 90 IF (QKK .LT. ZERO) T = -T QKK = QKK + T S = SQRT(T * QKK) GO TO 110 90 S = SQRT(T) IF (QKK .LT. ZERO) GO TO 100 QKK = QKK + T S = S * SQRT(QKK) GO TO 110 100 T = -T QKK = QKK + T S = S * SQRT(-QKK) 110 Q(K,K) = QKK C C *** SCALE (Q(K,K),...,Q(N,K)) TO HAVE NORM SQRT(2) *** C IF (S .LE. TINY) GO TO 140 CALL V7SCL(NK1, Q(K,K), ONE/S, Q(K,K)) C R(KK) = -T C C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q *** C IF (K .GE. P) GO TO 999 J = KK + K II = KK DO 120 I = KP1, P II = II + I CALL V2AXY(NK1, Q(K,I), - D7TPR(NK1,Q(K,K),Q(K,I)), 1 Q(K,K), Q(K,I)) T = Q(K,I) R(J) = T J = J + I T1 = R(II) IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2 120 CONTINUE 130 CONTINUE C C *** SINGULAR Q *** C 140 IERR = K KM1 = K - 1 J = KK DO 150 I = K, P CALL V7SCP(I-KM1, R(J), ZERO) J = J + I 150 CONTINUE C 999 RETURN C *** LAST CARD OF Q7RFH FOLLOWS *** END SUBROUTINE Q7RGS(IERR, IPIVOT, L, N, NN, NOPIVK, P, Q, R, W) C C *** COMPUTE QR FACTORIZATION VIA MODIFIED GRAM-SCHMIDT PROCEDURE C *** WITH COLUMN PIVOTING *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, L, N, NN, NOPIVK, P INTEGER IPIVOT(P) REAL Q(NN,P), R(1), W(P) C DIMENSION R(P*(P+1)/2) C C---------------------------- DESCRIPTION ---------------------------- C C THIS ROUTINE COMPUTES COLUMNS L THROUGH P OF A QR FACTORI- C ZATION OF THE MATRIX A THAT IS ORIGINALLY STORED IN COLUMNS L C THROUGH P OF Q. IT IS ASSUMED THAT COLUMNS 1 THROUGH L-1 OF C THE FACTORIZATION HAVE ALREADY BEEN STORED IN Q AND R. THIS C CODE USES THE MODIFIED GRAM-SCHMIDT PROCEDURE WITH REORTHOGONALI- C ZATION AND, IF NOPIVK ALLOWS IT, WITH COLUMN PIVOTING -- IF C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING. C IF IPIVOT(L) = 0 ON INPUT, THEN IPIVOT IS INITIALIZED SO THAT C IPIVOT(I) = I FOR I = L,...,P. WHATEVER THE ORIGINAL VALUE OF C IPIVOT(L), THE CORRESPONDING ELEMENTS OF IPIVOT ARE INTERCHANGED C WHENEVER COLUMN PIVOTING OCCURS. THUS IF IPIVOT(L) = 0 ON IN- C PUT, THEN THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF C Q*R EQUALS COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UP- C PER TRIANGULAR MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., C THE OUTPUT VECTOR R CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), C R(2,3), ..., R(P,P) (IN THAT ORDER). IF ALL GOES WELL, THEN THIS C ROUTINE SETS IERR = 0. BUT IF (PERMUTED) COLUMN K OF A IS C LINEARLY DEPENDENT ON (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR C IS SET TO K AND THE R MATRIX RETURNED HAS R(I,J) = 0 FOR C I .GE. K AND J .GE. K. IN THIS CASE COLUMNS K THROUGH P C OF THE Q RETURNED ARE NOT ORTHONORMAL. W IS A SCRATCH VECTOR. C THE ORIGINAL MATRIX A AND THE COMPUTED ORTHOGONAL MATRIX Q C ARE N BY P MATRICES. NN IS THE LEAD DIMENSION OF THE ARRAY Q C AND MUST SATISFY NN .GE. N. NO PARAMETER CHECKING IS DONE. C C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984). C C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I, II, J, K, KK, KM1, KP1, LM1 LOGICAL IPINIT REAL AK, SINGTL, T, T1, T2, WK EXTERNAL D7TPR, R7MDC, V2AXY, V7SCP, V7SWP, V2NRM, V7SCL REAL D7TPR, R7MDC, V2NRM C/+ REAL SQRT C/ REAL BIG, MEPS10, ONE, REOTOL, TEN, TINY, WTOL, ZERO C/6 C DATA ONE/1.0E+0/, REOTOL/0.25E+0/, TEN/1.E+1/, WTOL/0.75E+0/, C 1 ZERO/0.0E+0/ C/7 PARAMETER (ONE=1.0E+0, REOTOL=0.25E+0, TEN=1.E+1, WTOL=0.75E+0, 1 ZERO=0.0E+0) SAVE MEPS10, TINY C/ DATA MEPS10/0.0E+0/, TINY/0.0E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IERR = 0 IF (MEPS10 .GT. ZERO) GO TO 10 MEPS10 = TEN * R7MDC(3) TINY = R7MDC(1) BIG = R7MDC(6) IF (TINY*BIG .LT. ONE) TINY = ONE / BIG 10 SINGTL = FLOAT(MAX0(N,P)) * MEPS10 LM1 = L - 1 J = L*LM1/2 KK = J IPINIT = IPIVOT(L) .EQ. 0 C C *** INITIALIZE W, IPIVOT, DIAG(R), AND R(I,J) FOR I = 1,2,...,L-1 C *** AND J = L,L+1,...,P. C DO 50 I = L, P IF (IPINIT) IPIVOT(I) = I T = V2NRM(N, Q(1,I)) IF (T .GT. ZERO) GO TO 20 W(I) = ONE J = J + LM1 GO TO 40 20 W(I) = ZERO IF (LM1 .EQ. 0) GO TO 40 DO 30 K = 1, LM1 J = J + 1 T1 = D7TPR(N, Q(1,K), Q(1,I)) R(J) = T1 CALL V2AXY(N, Q(1,I), -T1, Q(1,K), Q(1,I)) W(I) = W(I) + (T1/T)**2 30 CONTINUE 40 J = J + I - LM1 R(J) = T 50 CONTINUE C C *** MAIN LOOP *** C DO 140 K = L, P KK = KK + K KP1 = K + 1 IF (K .LE. NOPIVK) GO TO 70 IF (K .GE. P) GO TO 70 C C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS *** C T = W(K) IF (T .LE. ZERO) GO TO 70 J = K DO 60 I = KP1, P IF (W(I) .GE. T) GO TO 60 T = W(I) J = I 60 CONTINUE IF (J .EQ. K) GO TO 70 C C *** INTERCHANGE COLUMNS K AND J *** C I = IPIVOT(K) IPIVOT(K) = IPIVOT(J) IPIVOT(J) = I W(J) = W(K) W(K) = T I = J*(J+1)/2 T1 = R(I) R(I) = R(KK) R(KK) = T1 CALL V7SWP(N, Q(1,K), Q(1,J)) IF (K .LE. 1) GO TO 70 I = I - J + 1 J = KK - K + 1 CALL V7SWP(K-1, R(I), R(J)) C C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE C *** WHETHER TO REORTHOGONALIZE IT. C 70 AK = R(KK) IF (AK .LE. ZERO) GO TO 150 T1 = AK R(KK) = ONE T2 = ONE WK = W(K) C C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K)) C *** AND CHECK FOR SINGULARITY. C 80 IF (WK .LT. WTOL) GO TO 90 T = V2NRM(N, Q(1,K)) IF (T*T2 / AK .GT. SINGTL) GO TO 100 GO TO 150 90 T = SQRT(ONE - WK) IF (T*T2 .LE. SINGTL) GO TO 150 T = T * AK C 100 IF (T .LT. TINY) GO TO 150 R(KK) = T * R(KK) CALL V7SCL(N, Q(1,K), ONE/T, Q(1,K)) IF (T/T1 .GE. REOTOL) GO TO 120 C C *** REORTHOGONALIZE COLUMN K *** C AK = ONE T2 = T * T2 WK = ZERO J = KK - K KM1 = K - 1 DO 110 I = 1, KM1 J = J + 1 T = D7TPR(N, Q(1,I), Q(1,K)) WK = WK + T*T R(J) = R(J) + T*R(KK) 110 CALL V2AXY(N, Q(1,K), -T, Q(1,I), Q(1,K)) T1 = ONE GO TO 80 C C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q *** C 120 IF (K .GE. P) GO TO 999 J = KK + K II = KK DO 130 I = KP1, P II = II + I T = D7TPR(N, Q(1,K), Q(1,I)) R(J) = T J = J + I CALL V2AXY(N, Q(1,I), -T, Q(1,K), Q(1,I)) T1 = R(II) IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2 130 CONTINUE 140 CONTINUE C C *** SINGULAR Q *** C 150 IERR = K KM1 = K - 1 J = KK DO 160 I = K, P CALL V7SCP(I-KM1, R(J), ZERO) J = J + I 160 CONTINUE C 999 RETURN C *** LAST CARD OF Q7RGS FOLLOWS *** END SUBROUTINE Q7RSH(K, P, HAVQTR, QTR, R, W) C C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY *** C LOGICAL HAVQTR INTEGER K, P REAL QTR(P), R(1), W(P) C DIMSNSION R(P*(P+1)/2) C REAL H2RFG EXTERNAL H2RFA, H2RFG, V7CPY C C *** LOCAL VARIABLES *** C INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1 REAL A, B, T, WJ, X, Y, Z, ZERO C DATA ZERO/0.0E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (K .GE. P) GO TO 999 KM1 = K - 1 K1 = K * KM1 / 2 CALL V7CPY(K, W, R(K1+1)) WJ = W(K) PM1 = P - 1 J1 = K1 + KM1 DO 50 J = K, PM1 JM1 = J - 1 JP1 = J + 1 IF (JM1 .GT. 0) CALL V7CPY(JM1, R(K1+1), R(J1+2)) J1 = J1 + JP1 K1 = K1 + J A = R(J1) B = R(J1+1) IF (B .NE. ZERO) GO TO 10 R(K1) = A X = ZERO Z = ZERO GO TO 40 10 R(K1) = H2RFG(A, B, X, Y, Z) IF (J .EQ. PM1) GO TO 30 I1 = J1 DO 20 I = JP1, PM1 I1 = I1 + I CALL H2RFA(1, R(I1), R(I1+1), X, Y, Z) 20 CONTINUE 30 IF (HAVQTR) CALL H2RFA(1, QTR(J), QTR(JP1), X, Y, Z) 40 T = X * WJ W(J) = WJ + T WJ = T * Z 50 CONTINUE W(P) = WJ CALL V7CPY(P, R(K1+1), W) 999 RETURN END REAL FUNCTION R1MACH(I) INTEGER I C C SINGLE-PRECISION MACHINE CONSTANTS C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING. C R1MACH(5) = LOG10(B) C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) C needs to be (2) for AUTODOUBLE, HARRIS SLASH 6, ... INTEGER SC SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC REAL RMACH(5) EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) INTEGER J, K, L, T3E(3) DATA T3E(1) / 9777664 / DATA T3E(2) / 5323660 / DATA T3E(3) / 46980 / C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES, C INCLUDING AUTO-DOUBLE COMPILERS. C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 C ON THE NEXT LINE DATA SC/0/ C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY C mail netlib@research.bell-labs.com C send old1mach from blas C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 /, SC/987/ C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 /, SC/987/ C IF (SC .NE. 987) THEN * *** CHECK FOR AUTODOUBLE *** SMALL(2) = 0 RMACH(1) = 1E13 IF (SMALL(2) .NE. 0) THEN * *** AUTODOUBLED *** IF ( SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) THEN * *** IEEE BIG ENDIAN *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2146435071 LARGE(2) = -1 RIGHT(1) = 1017118720 RIGHT(2) = 0 DIVER(1) = 1018167296 DIVER(2) = 0 LOG10(1) = 1070810131 LOG10(2) = 1352628735 ELSE IF ( SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528) THEN * *** IEEE LITTLE ENDIAN *** SMALL(2) = 1048576 SMALL(1) = 0 LARGE(2) = 2146435071 LARGE(1) = -1 RIGHT(2) = 1017118720 RIGHT(1) = 0 DIVER(2) = 1018167296 DIVER(1) = 0 LOG10(2) = 1070810131 LOG10(1) = 1352628735 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** SMALL(1) = 128 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 9344 RIGHT(2) = 0 DIVER(1) = 9472 DIVER(2) = 0 LOG10(1) = 546979738 LOG10(2) = -805796613 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 856686592 RIGHT(2) = 0 DIVER(1) = 873463808 DIVER(2) = 0 LOG10(1) = 1091781651 LOG10(2) = 1352628735 ELSE WRITE(*,9010) STOP 777 END IF ELSE RMACH(1) = 1234567. IF (SMALL(1) .EQ. 1234613304) THEN * *** IEEE *** SMALL(1) = 8388608 LARGE(1) = 2139095039 RIGHT(1) = 864026624 DIVER(1) = 872415232 LOG10(1) = 1050288283 ELSE IF (SMALL(1) .EQ. -1271379306) THEN * *** VAX *** SMALL(1) = 128 LARGE(1) = -32769 RIGHT(1) = 13440 DIVER(1) = 13568 LOG10(1) = 547045274 ELSE IF (SMALL(1) .EQ. 1175639687) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 LARGE(1) = 2147483647 RIGHT(1) = 990904320 DIVER(1) = 1007681536 LOG10(1) = 1091781651 ELSE IF (SMALL(1) .EQ. 1251390520) THEN * *** CONVEX C-1 *** SMALL(1) = 8388608 LARGE(1) = 2147483647 RIGHT(1) = 880803840 DIVER(1) = 889192448 LOG10(1) = 1067065499 ELSE DO 10 L = 1, 3 J = SMALL(1) / 10000000 K = SMALL(1) - 10000000*J IF (K .NE. T3E(L)) GO TO 20 SMALL(1) = J 10 CONTINUE * *** CRAY T3E *** CALL I1MCRA(SMALL, K, 16, 0, 0) CALL I1MCRA(LARGE, K, 32751, 16777215, 16777215) CALL I1MCRA(RIGHT, K, 15520, 0, 0) CALL I1MCRA(DIVER, K, 15536, 0, 0) CALL I1MCRA(LOG10, K, 16339, 4461392, 10451455) GO TO 30 20 CALL I1MCRA(J, K, 16405, 9876536, 0) IF (SMALL(1) .NE. J) THEN WRITE(*,9020) STOP 777 END IF * *** CRAY 1, XMP, 2, AND 3 *** CALL I1MCRA(SMALL(1), K, 8195, 8388608, 1) CALL I1MCRA(LARGE(1), K, 24574, 16777215, 16777214) CALL I1MCRA(RIGHT(1), K, 16338, 8388608, 0) CALL I1MCRA(DIVER(1), K, 16339, 8388608, 0) CALL I1MCRA(LOG10(1), K, 16383, 10100890, 8715216) END IF END IF 30 SC = 987 END IF * SANITY CHECK IF (RMACH(4) .GE. 1.0) STOP 776 IF (I .LT. 1 .OR. I .GT. 5) THEN WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.' STOP END IF R1MACH = RMACH(I) RETURN 9010 FORMAT(/' Adjust autodoubled R1MACH by getting data'/ *' appropriate for your machine from D1MACH.') 9020 FORMAT(/' Adjust R1MACH by uncommenting data statements'/ *' appropriate for your machine.') * /* C source for R1MACH -- remove the * in column 1 */ *#include *#include *#include *float r1mach_(long *i) *{ * switch(*i){ * case 1: return FLT_MIN; * case 2: return FLT_MAX; * case 3: return FLT_EPSILON/FLT_RADIX; * case 4: return FLT_EPSILON; * case 5: return log10((double)FLT_RADIX); * } * fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i); * exit(1); return 0; /* else complaint of missing return value */ *} END SUBROUTINE I1MCRA(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END REAL FUNCTION R7MDC(K) C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C INTEGER K C C *** THE CONSTANT RETURNED DEPENDS ON K... C C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS. C *** K = 2... SQUARE ROOT OF ETA. C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1. C *** K = 4... SQUARE ROOT OF MACHEP. C *** K = 5... SQUARE ROOT OF BIG (SEE K = 6). C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS. C REAL BIG, ETA, MACHEP C/+ REAL SQRT C/ REAL R1MACH, ZERO EXTERNAL R1MACH DATA BIG/0.E+0/, ETA/0.E+0/, MACHEP/0.E+0/, ZERO/0.E+0/ IF (BIG .GT. ZERO) GO TO 1 BIG = R1MACH(2) ETA = R1MACH(1) MACHEP = R1MACH(4) 1 CONTINUE C C------------------------------- BODY -------------------------------- C GO TO (10, 20, 30, 40, 50, 60), K C 10 R7MDC = ETA GO TO 999 C 20 R7MDC = SQRT(256.E+0*ETA)/16.E+0 GO TO 999 C 30 R7MDC = MACHEP GO TO 999 C 40 R7MDC = SQRT(MACHEP) GO TO 999 C 50 R7MDC = SQRT(BIG/256.E+0)*16.E+0 GO TO 999 C 60 R7MDC = BIG C 999 RETURN C *** LAST CARD OF R7MDC FOLLOWS *** END SUBROUTINE R7TVM(N, P, Y, D, U, X) C C *** SET Y TO R*X, WHERE R IS THE UPPER TRIANGULAR MATRIX WHOSE C *** DIAGONAL IS IN D AND WHOSE STRICT UPPER TRIANGLE IS IN U. C C *** X AND Y MAY SHARE STORAGE. C INTEGER N, P REAL Y(P), D(P), U(N,P), X(P) C REAL D7TPR EXTERNAL D7TPR C C *** LOCAL VARIABLES *** C INTEGER I, II, PL, PP1 REAL T C C *** BODY *** C PL = MIN0(N, P) PP1 = PL + 1 DO 10 II = 1, PL I = PP1 - II T = X(I) * D(I) IF (I .GT. 1) T = T + D7TPR(I-1, U(1,I), X) Y(I) = T 10 CONTINUE 999 RETURN C *** LAST LINE OF R7TVM FOLLOWS *** END SUBROUTINE RETSRC(IROLD) C C THIS ROUTINE SETS LRECOV = IROLD. C C IF THE CURRENT ERROR BECOMES UNRECOVERABLE, C THE MESSAGE IS PRINTED AND EXECUTION STOPS. C C ERROR STATES - C C 1 - ILLEGAL VALUE OF IROLD. C C/6S C IF (IROLD.LT.1 .OR. IROLD.GT.2) C 1 CALL SETERR(31HRETSRC - ILLEGAL VALUE OF IROLD,31,1,2) C/7S IF (IROLD.LT.1 .OR. IROLD.GT.2) 1 CALL SETERR('RETSRC - ILLEGAL VALUE OF IROLD',31,1,2) C/ C ITEMP=I8SAVE(2,IROLD,.TRUE.) C C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. C IF (IROLD.EQ.1 .OR. I8SAVE(1,0,.FALSE.).EQ.0) RETURN C CALL EPRINT STOP C END REAL FUNCTION RLDST(P, D, X, X0) C C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 *** C *** NL2SOL VERSION 2.2 *** C INTEGER P REAL D(P), X(P), X0(P) C INTEGER I REAL EMAX, T, XMAX, ZERO C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C C *** BODY *** C EMAX = ZERO XMAX = ZERO DO 10 I = 1, P T = ABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * ( ABS(X(I)) + ABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE RLDST = ZERO IF (XMAX .GT. ZERO) RLDST = EMAX / XMAX 999 RETURN C *** LAST CARD OF RLDST FOLLOWS *** END SUBROUTINE RMNF(D, FX, IV, LIV, LV, N, V, X) C C *** ITERATION DRIVER FOR MNF... C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER LIV, LV, N INTEGER IV(LIV) REAL D(N), FX, X(N), V(LV) C DIMENSION V(77 + N*(N+17)/2) C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNG IN AN ATTEMPT C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR RMNF ARE THE SAME AS THOSE FOR MNG C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE C GRADIENT OF THE OBJECTIVE FUNCTION AT X, RMNF CALLS S7GRD, C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1. C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD C (AND IS NOT DESCRIBED IN MNG). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR MNF THAN FOR MNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (AUGUST 1982). C C---------------------------- DECLARATIONS --------------------------- C REAL D7TPR EXTERNAL IVSET, D7TPR, S7GRD, RMNG, V7SCP C C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C S7GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION. C RMNG.... REVERSE-COMMUNICATION ROUTINE THAT DOES MNG ALGORITHM. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C INTEGER ALPHA, G1, I, IV1, J, K, W REAL ZERO C C *** SUBSCRIPTS FOR IV *** C INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, NITER, SGIRC, TOOBIG, 1 VNEED C C/6 C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/, C 1 NITER/31/, SGIRC/57/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30, 1 NITER=31, SGIRC=57, TOOBIG=2, VNEED=4) C/ C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IV1 = IV(1) IF (IV1 .EQ. 1) GO TO 10 IF (IV1 .EQ. 2) GO TO 50 IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*N + 6 IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) C 20 CALL RMNG(D, FX, V(G1), IV, LIV, LV, N, V, X) IF (IV(1) - 2) 999, 30, 70 C C *** COMPUTE GRADIENT *** C 30 IF (IV(NITER) .EQ. 0) CALL V7SCP(N, V(G1), ZERO) J = IV(LMAT) K = G1 - N DO 40 I = 1, N V(K) = D7TPR(I, V(J), V(J)) K = K + 1 J = J + I 40 CONTINUE C *** UNDO INCREMENT OF IV(NGCALL) DONE BY RMNG *** IV(NGCALL) = IV(NGCALL) - 1 C *** STORE RETURN CODE FROM S7GRD IN IV(SGIRC) *** IV(SGIRC) = 0 C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... *** FX = V(F) GO TO 60 C C *** GRADIENT LOOP *** C 50 IF (IV(TOOBIG) .NE. 0) GO TO 10 C 60 G1 = IV(G) ALPHA = G1 - N W = ALPHA - 6 CALL S7GRD(V(ALPHA), D, V(ETA0), FX, V(G1), IV(SGIRC), N, V(W),X) IF (IV(SGIRC) .EQ. 0) GO TO 10 IV(NGCALL) = IV(NGCALL) + 1 GO TO 999 C 70 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) + N + 6 IV(NEXTV) = IV(G) + N IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF RMNF FOLLOWS *** END SUBROUTINE RMNFB(B, D, FX, IV, LIV, LV, P, V, X) C C *** ITERATION DRIVER FOR MNF... C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS. C INTEGER LIV, LV, P INTEGER IV(LIV) REAL B(2,P), D(P), FX, X(P), V(LV) C DIMENSION IV(59 + P), V(77 + P*(P+23)/2) C C *** PURPOSE *** C C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNGB IN AN ATTEMPT C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED) C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.) C C *** PARAMETERS *** C C THE PARAMETERS FOR RMNFB ARE THE SAME AS THOSE FOR MNG C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE C GRADIENT OF THE OBJECTIVE FUNCTION AT X, RMNFB CALLS S3GRD, C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1. C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD C (AND IS NOT DESCRIBED IN MNG). C C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF... C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E), C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3, C WHERE MACHEP IS THE UNIT ROUNDOFF. C C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT C MEANINGS FOR MNF THAN FOR MNG... C C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E., C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A C LIMIT ON IV(NFCALL). C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (AUGUST 1982). C C---------------------------- DECLARATIONS --------------------------- C REAL D7TPR EXTERNAL IVSET, D7TPR, S3GRD, RMNGB, V7SCP C C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C S3GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION. C RMNGB... REVERSE-COMMUNICATION ROUTINE THAT DOES MNGB ALGORITHM. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C INTEGER ALPHA, ALPHA0, G1, I, IPI, IV1, J, K, W REAL ZERO C C *** SUBSCRIPTS FOR IV *** C INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, 1 NITER, PERM, SGIRC, TOOBIG, VNEED C C/6 C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/, C 1 NITER/31/, PERM/58/, SGIRC/57/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30, 1 NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4) C/ C/6 C DATA ZERO/0.E+0/ C/7 PARAMETER (ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IV1 = IV(1) IF (IV1 .EQ. 1) GO TO 10 IF (IV1 .EQ. 2) GO TO 50 IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*P + 6 IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 G1 = 1 IF (IV1 .EQ. 12) IV(1) = 13 GO TO 20 C 10 G1 = IV(G) C 20 CALL RMNGB(B, D, FX, V(G1), IV, LIV, LV, P, V, X) IF (IV(1) - 2) 999, 30, 80 C C *** COMPUTE GRADIENT *** C 30 IF (IV(NITER) .EQ. 0) CALL V7SCP(P, V(G1), ZERO) J = IV(LMAT) ALPHA0 = G1 - P - 1 IPI = IV(PERM) DO 40 I = 1, P K = ALPHA0 + IV(IPI) V(K) = D7TPR(I, V(J), V(J)) IPI = IPI + 1 J = J + I 40 CONTINUE C *** UNDO INCREMENT OF IV(NGCALL) DONE BY RMNGB *** IV(NGCALL) = IV(NGCALL) - 1 C *** STORE RETURN CODE FROM S3GRD IN IV(SGIRC) *** IV(SGIRC) = 0 C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... *** FX = V(F) GO TO 60 C C *** GRADIENT LOOP *** C 50 IF (IV(TOOBIG) .NE. 0) GO TO 10 C 60 G1 = IV(G) ALPHA = G1 - P W = ALPHA - 6 CALL S3GRD(V(ALPHA), B, D, V(ETA0), FX, V(G1), IV(SGIRC), P, 1 V(W), X) I = IV(SGIRC) IF (I .EQ. 0) GO TO 10 IF (I .LE. P) GO TO 70 IV(TOOBIG) = 1 GO TO 10 C 70 IV(NGCALL) = IV(NGCALL) + 1 GO TO 999 C 80 IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) + P + 6 IV(NEXTV) = IV(G) + P IF (IV1 .NE. 13) GO TO 10 C 999 RETURN C *** LAST CARD OF RMNFB FOLLOWS *** END SUBROUTINE RMNG(D, FX, G, IV, LIV, LV, N, V, X) C C *** CARRY OUT MNG (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING C *** DOUBLE-DOGLEG/BFGS STEPS. C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N INTEGER IV(LIV) REAL D(N), FX, G(N), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV (AT LEAST 60). C LV... LENGTH OF V (AT LEAST 71 + N*(N+13)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO MNG (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT MNG USES FOR STORING G IS NOT NEEDED). C MOREOVER, COMPARED WITH MNG, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM MNG (AND MNF), IS NOT REFERENCED BY C RMNG OR THE SUBROUTINES IT CALLS. C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN RMNG IS CALLED C WITH IV(1) = 12, 13, OR 14. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL RMNG AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE RMNG TO IG- C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT C MNG PASSES TO CALCF (FOR POSSIBLE USE BY CALCG) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR C OF F AT X, AND CALL RMNG AGAIN, HAVING CHANGED NONE OF C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT MNG PASSES C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE C EVALUATED, THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN C WHICH CASE RMNG WILL RETURN WITH IV(1) = 65. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C (SEE MNG FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DUMMY, G01, I, K, L, LSTGST, NWTST1, RSTRST, STEP1, 1 TEMP1, W, X01, Z REAL T C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, RLDST, V2NRM EXTERNAL A7SST, D7DOG, IVSET, D7TPR, ITSUM, L7ITV, L7IVM, 1 L7TVM, L7UPD, L7VML, PARCK, RLDST, STOPX, V2AXY, 2 V7CPY, V7SCP, V7VMP, V2NRM, W7ZBF C C A7SST.... ASSESSES CANDIDATE STEP. C D7DOG.... COMPUTES DOUBLE-DOGLEG (CANDIDATE) STEP. C IVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C L7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C L7IVM... MULTIPLIES INVERSE OF LOWER TRIANGLE TIMES VECTOR. C L7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION. C L7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR. C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE). C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C W7ZBF... COMPUTES W AND Z FOR L7UPD CORRESPONDING TO BFGS UPDATE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DST0, F, F0, FDIF, 1 GTHG, GTSTEP, G0, INCFAC, INITH, IRC, KAGQT, LMAT, LMAX0, 2 LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, 3 NGCALL, NITER, NREDUC, NWTSTP, PREDUC, RADFAC, RADINC, 4 RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, TOOBIG, 5 TUNER4, TUNER5, VNEED, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, DG/37/, G0/48/, INITH/25/, IRC/29/, KAGQT/33/, C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NFCALL/6/, C 2 NFGCAL/7/, NGCALL/30/, NITER/31/, NWTSTP/34/, RADINC/8/, C 3 RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/, C 4 VNEED/4/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, G0=48, INITH=25, IRC=29, KAGQT=33, 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NFCALL=6, 2 NFGCAL=7, NGCALL=30, NITER=31, NWTSTP=34, RADINC=8, 3 RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, 4 VNEED=4, XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DST0/3/, F/10/, F0/13/, C 1 FDIF/11/, GTHG/44/, GTSTEP/4/, INCFAC/23/, LMAT/42/, C 2 LMAX0/35/, LMAXS/36/, NEXTV/47/, NREDUC/6/, PREDUC/7/, C 3 RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/, TUNER4/29/, C 4 TUNER5/30/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DST0=3, F=10, F0=13, 1 FDIF=11, GTHG=44, GTSTEP=4, INCFAC=23, LMAT=42, 2 LMAX0=35, LMAXS=36, NEXTV=47, NREDUC=6, PREDUC=7, 3 RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, TUNER4=29, 4 TUNER5=30) C/ C C/6 C DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, C 1 ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, 1 ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13) 1 IV(VNEED) = IV(VNEED) + N*(N+13)/2 CALL PARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (190, 190, 190, 190, 190, 190, 120, 90, 120, 10, 10, 20), I C C *** STORAGE ALLOCATION *** C 10 L = IV(LMAT) IV(X0) = L + N*(N+1)/2 IV(STEP) = IV(X0) + N IV(STLSTG) = IV(STEP) + N IV(G0) = IV(STLSTG) + N IV(NWTSTP) = IV(G0) + N IV(DG) = IV(NWTSTP) + N IV(NEXTV) = IV(DG) + N IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 V(RAD0) = ZERO IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT)) IF (IV(INITH) .NE. 1) GO TO 40 C C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 *** C L = IV(LMAT) CALL V7SCP(N*(N+1)/2, V(L), ZERO) K = L - 1 DO 30 I = 1, N K = K + I T = D(I) IF (T .LE. ZERO) T = ONE V(K) = T 30 CONTINUE C C *** COMPUTE INITIAL FUNCTION VALUE *** C 40 IV(1) = 1 GO TO 999 C 50 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 190 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 350 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 350 C 70 DG1 = IV(DG) CALL V7VMP(N, V(DG1), G, D, -1) V(DGNORM) = V2NRM(N, V(DG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 340 IF (IV(MODE) .EQ. 0) GO TO 300 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 80 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) 90 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 100 IV(1) = 10 GO TO 350 C C *** UPDATE RADIUS *** C 100 IV(NITER) = K + 1 IF (K .GT. 0) V(RADIUS) = V(RADFAC) * V(DSTNRM) C C *** INITIALIZE FOR START OF NEXT ITERATION *** C G01 = IV(G0) X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0, G TO G0 *** C CALL V7CPY(N, V(X01), X) CALL V7CPY(N, V(G01), G) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 110 IF (.NOT. STOPX(DUMMY)) GO TO 130 IV(1) = 11 GO TO 140 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 120 IF (V(F) .GE. V(F0)) GO TO 130 V(RADFAC) = ONE K = IV(NITER) GO TO 100 C 130 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 150 IV(1) = 9 140 IF (V(F) .GE. V(F0)) GO TO 350 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 290 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 150 STEP1 = IV(STEP) DG1 = IV(DG) NWTST1 = IV(NWTSTP) IF (IV(KAGQT) .GE. 0) GO TO 160 L = IV(LMAT) CALL L7IVM(N, V(NWTST1), V(L), G) V(NREDUC) = HALF * D7TPR(N, V(NWTST1), V(NWTST1)) CALL L7ITV(N, V(NWTST1), V(L), V(NWTST1)) CALL V7VMP(N, V(STEP1), V(NWTST1), D, 1) V(DST0) = V2NRM(N, V(STEP1)) CALL V7VMP(N, V(DG1), V(DG1), D, -1) CALL L7TVM(N, V(STEP1), V(L), V(DG1)) V(GTHG) = V2NRM(N, V(STEP1)) IV(KAGQT) = 0 160 CALL D7DOG(V(DG1), LV, N, V(NWTST1), V(STEP1), V) IF (IV(IRC) .NE. 6) GO TO 170 IF (IV(RESTOR) .NE. 2) GO TO 190 RSTRST = 2 GO TO 200 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 170 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 190 IF (IV(IRC) .NE. 5) GO TO 180 IF (V(RADFAC) .LE. ONE) GO TO 180 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 180 IF (IV(RESTOR) .NE. 2) GO TO 190 RSTRST = 0 GO TO 200 C C *** COMPUTE F(X0 + STEP) *** C 180 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 190 RSTRST = 3 200 X01 = IV(X0) V(RELDX) = RLDST(N, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (240, 210, 220, 230), I 210 CALL V7CPY(N, X, V(X01)) GO TO 240 220 CALL V7CPY(N, V(LSTGST), V(STEP1)) GO TO 240 230 CALL V7CPY(N, V(STEP1), V(LSTGST)) CALL V2AXY(N, X, ONE, V(STEP1), V(X01)) V(RELDX) = RLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 240 K = IV(IRC) GO TO (250,280,280,280,250,260,270,270,270,270,270,270,330,300), K C C *** RECOMPUTE STEP WITH CHANGED RADIUS *** C 250 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 110 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 260 V(RADIUS) = V(LMAXS) GO TO 150 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 270 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 340 IF (IV(XIRC) .EQ. 14) GO TO 340 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 280 IF (IV(IRC) .NE. 3) GO TO 290 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C L = IV(LMAT) CALL L7TVM(N, V(TEMP1), V(L), V(STEP1)) CALL L7VML(N, V(TEMP1), V(L), V(TEMP1)) C C *** COMPUTE GRADIENT *** C 290 IV(NGCALL) = IV(NGCALL) + 1 IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 300 G01 = IV(G0) CALL V2AXY(N, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) IF (IV(IRC) .NE. 3) GO TO 320 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C CALL V2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1)) CALL V7VMP(N, V(TEMP1), V(TEMP1), D, -1) C C *** DO GRADIENT TESTS *** C IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) 1 GO TO 310 IF ( D7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 320 310 V(RADFAC) = V(INCFAC) C C *** UPDATE H, LOOP *** C 320 W = IV(NWTSTP) Z = IV(X0) L = IV(LMAT) CALL W7ZBF(V(L), N, V(STEP1), V(W), V(G01), V(Z)) C C ** USE THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH.. CALL L7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W), V(Z)) IV(1) = 2 GO TO 80 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 330 IV(1) = 64 GO TO 350 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 340 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 350 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) C 999 RETURN C C *** LAST LINE OF RMNG FOLLOWS *** END SUBROUTINE RMNGB(B, D, FX, G, IV, LIV, LV, N, V, X) C C *** CARRY OUT MNGB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS, C *** USING DOUBLE-DOGLEG/BFGS STEPS. C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, N INTEGER IV(LIV) REAL B(2,N), D(N), FX, G(N), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X. C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV (AT LEAST 59) + N. C LV... LENGTH OF V (AT LEAST 71 + N*(N+19)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO MNGB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT MNGB USES FOR STORING G IS NOT NEEDED). C MOREOVER, COMPARED WITH MNGB, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM MNGB (AND SMSNOB), IS NOT REFERENCED BY C RMNGB OR THE SUBROUTINES IT CALLS. C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN RMNGB IS CALLED C WITH IV(1) = 12, 13, OR 14. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL RMNGB AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE RMNGB TO IG- C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT C MNGB PASSES TO CALCF (FOR POSSIBLE USE BY CALCG) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR C OF F AT X, AND CALL RMNGB AGAIN, HAVING CHANGED NONE OF C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT MNGB PASSES C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE C EVALUATED, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN C WHICH CASE RMNGB WILL RETURN WITH IV(1) = 65. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C (SEE MNG FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DSTEP1, DUMMY, G01, I, I1, IPI, IPN, J, K, L, LSTGST, 1 N1, NP1, NWTST1, RSTRST, STEP1, TEMP0, TEMP1, TD1, TG1, 2 W1, X01, Z REAL GI, T, XI C C *** CONSTANTS *** C REAL NEGONE, ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, RLDST, V2NRM EXTERNAL A7SST, D7DGB, IVSET, D7TPR, I7SHFT, ITSUM, L7TVM, 1 L7UPD, L7VML, PARCK, Q7RSH, RLDST, STOPX, V2NRM, 2 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP, W7ZBF C C A7SST.... ASSESSES CANDIDATE STEP. C D7DGB... COMPUTES SIMPLY BOUNDED DOUBLE-DOGLEG (CANDIDATE) STEP. C IVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C I7SHFT... CYCLICALLLY SHIFTS AN ARRAY OF INTEGERS. C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C L7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION. C L7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR. C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C Q7RSH... CYCLICALLY SHIFTS CHOLESKY FACTOR. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7IPR... CYCLICALLY SHIFTS A FLOATING-POINT ARRAY. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE). C W7ZBF... COMPUTES W AND Z FOR L7UPD CORRESPONDING TO BFGS UPDATE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, F, F0, FDIF, 1 GTSTEP, INCFAC, INITH, IRC, IVNEED, KAGQT, LMAT, 2 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NC, NEXTIV, 3 NEXTV, NFCALL, NFGCAL, NGCALL, NITER, NWTSTP, PERM, 4 PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, 4 STGLIM, STLSTG, TOOBIG, TUNER4, TUNER5, VNEED, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT NC IS STORED IN IV(G0)) *** C C/6 C DATA CNVCOD/55/, DG/37/, INITH/25/, IRC/29/, IVNEED/3/, KAGQT/33/, C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NC/48/, C 2 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, C 3 NITER/31/, NWTSTP/34/, PERM/58/, RADINC/8/, RESTOR/9/, C 4 STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, INITH=25, IRC=29, IVNEED=3, KAGQT=33, 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NC=48, 2 NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, 3 NITER=31, NWTSTP=34, PERM=58, RADINC=8, RESTOR=9, 4 STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, XIRC=13, 5 X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, F/10/, F0/13/, FDIF/11/, C 1 GTSTEP/4/, INCFAC/23/, LMAT/42/, LMAX0/35/, LMAXS/36/, C 2 PREDUC/7/, RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/, C 3 TUNER4/29/, TUNER5/30/, VNEED/4/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, F=10, F0=13, FDIF=11, 1 GTSTEP=4, INCFAC=23, LMAT=42, LMAX0=35, LMAXS=36, 2 PREDUC=7, RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, 3 TUNER4=29, TUNER5=30, VNEED=4) C/ C C/6 C DATA NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, ZERO/0.E+0/ C/7 PARAMETER (NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 70 IF (I .EQ. 2) GO TO 80 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IF (IV(1) .LT. 12) GO TO 10 IF (IV(1) .GT. 13) GO TO 10 IV(VNEED) = IV(VNEED) + N*(N+19)/2 IV(IVNEED) = IV(IVNEED) + N 10 CALL PARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (250, 250, 250, 250, 250, 250, 190, 150, 190, 20, 20, 30), I C C *** STORAGE ALLOCATION *** C 20 L = IV(LMAT) IV(X0) = L + N*(N+1)/2 IV(STEP) = IV(X0) + 2*N IV(STLSTG) = IV(STEP) + 2*N IV(NWTSTP) = IV(STLSTG) + N IV(DG) = IV(NWTSTP) + 2*N IV(NEXTV) = IV(DG) + 2*N IV(NEXTIV) = IV(PERM) + N IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 IV(NC) = N V(RAD0) = ZERO C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(PERM) DO 40 I = 1, N IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 410 40 CONTINUE C IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT)) IF (IV(INITH) .NE. 1) GO TO 60 C C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 *** C L = IV(LMAT) CALL V7SCP(N*(N+1)/2, V(L), ZERO) K = L - 1 DO 50 I = 1, N K = K + I T = D(I) IF (T .LE. ZERO) T = ONE V(K) = T 50 CONTINUE C C *** GET INITIAL FUNCTION VALUE *** C 60 IV(1) = 1 GO TO 440 C 70 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 250 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 430 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 80 IF (IV(TOOBIG) .EQ. 0) GO TO 90 IV(1) = 65 GO TO 430 C C *** CHOOSE INITIAL PERMUTATION *** C 90 IPI = IV(PERM) IPN = IPI + N N1 = N NP1 = N + 1 L = IV(LMAT) W1 = IV(NWTSTP) + N K = N - IV(NC) DO 120 I = 1, N IPN = IPN - 1 J = IV(IPN) IF (B(1,J) .GE. B(2,J)) GO TO 100 XI = X(J) GI = G(J) IF (XI .LE. B(1,J) .AND. GI .GT. ZERO) GO TO 100 IF (XI .GE. B(2,J) .AND. GI .LT. ZERO) GO TO 100 C *** DISALLOW CONVERGENCE IF X(J) HAS JUST BEEN FREED *** IF (I .LE. K) IV(CNVCOD) = 0 GO TO 120 100 I1 = NP1 - I IF (I1 .GE. N1) GO TO 110 CALL I7SHFT(N1, I1, IV(IPI)) CALL Q7RSH(I1, N1, .FALSE., G, V(L), V(W1)) 110 N1 = N1 - 1 120 CONTINUE C IV(NC) = N1 V(DGNORM) = ZERO IF (N1 .LE. 0) GO TO 130 DG1 = IV(DG) CALL V7VMP(N, V(DG1), G, D, -1) CALL V7IPR(N, IV(IPI), V(DG1)) V(DGNORM) = V2NRM(N1, V(DG1)) 130 IF (IV(CNVCOD) .NE. 0) GO TO 420 IF (IV(MODE) .EQ. 0) GO TO 370 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 140 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) 150 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 160 IV(1) = 10 GO TO 430 C C *** UPDATE RADIUS *** C 160 IV(NITER) = K + 1 IF (K .EQ. 0) GO TO 170 T = V(RADFAC) * V(DSTNRM) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 170 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0 *** C CALL V7CPY(N, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 180 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 210 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 190 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 160 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220 IV(1) = 9 210 IF (V(F) .GE. V(F0)) GO TO 430 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 360 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 220 STEP1 = IV(STEP) DG1 = IV(DG) NWTST1 = IV(NWTSTP) W1 = NWTST1 + N DSTEP1 = STEP1 + N IPI = IV(PERM) L = IV(LMAT) TG1 = DG1 + N X01 = IV(X0) TD1 = X01 + N CALL D7DGB(B, D, V(DG1), V(DSTEP1), G, IV(IPI), IV(KAGQT), 1 V(L), LV, N, IV(NC), V(NWTST1), V(STEP1), V(TD1), 2 V(TG1), V, V(W1), V(X01)) IF (IV(IRC) .NE. 6) GO TO 230 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 2 GO TO 260 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 230 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 250 IF (IV(IRC) .NE. 5) GO TO 240 IF (V(RADFAC) .LE. ONE) GO TO 240 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 0 GO TO 260 C C *** COMPUTE F(X0 + STEP) *** C 240 CALL V2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 440 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 250 RSTRST = 3 260 X01 = IV(X0) V(RELDX) = RLDST(N, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (300, 270, 280, 290), I 270 CALL V7CPY(N, X, V(X01)) GO TO 300 280 CALL V7CPY(N, V(LSTGST), X) GO TO 300 290 CALL V7CPY(N, X, V(LSTGST)) CALL V2AXY(N, V(STEP1), NEGONE, V(X01), X) V(RELDX) = RLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 300 K = IV(IRC) GO TO (310,340,340,340,310,320,330,330,330,330,330,330,400,370), K C C *** RECOMPUTE STEP WITH CHANGED RADIUS *** C 310 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 180 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 320 V(RADIUS) = V(LMAXS) GO TO 220 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 330 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 420 IF (IV(XIRC) .EQ. 14) GO TO 420 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 340 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(N, V(STEP1), NEGONE, V(X01), X) IF (IV(IRC) .NE. 3) GO TO 360 C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C C *** USE X0 AS TEMPORARY... C IPI = IV(PERM) CALL V7CPY(N, V(X01), V(STEP1)) CALL V7IPR(N, IV(IPI), V(X01)) L = IV(LMAT) CALL L7TVM(N, V(X01), V(L), V(X01)) CALL L7VML(N, V(X01), V(L), V(X01)) C C *** UNPERMUTE X0 INTO TEMP1 *** C TEMP1 = IV(STLSTG) TEMP0 = TEMP1 - 1 DO 350 I = 1, N J = IV(IPI) IPI = IPI + 1 K = TEMP0 + J V(K) = V(X01) X01 = X01 + 1 350 CONTINUE C C *** SAVE OLD GRADIENT, COMPUTE NEW ONE *** C 360 G01 = IV(NWTSTP) + N CALL V7CPY(N, V(G01), G) IV(NGCALL) = IV(NGCALL) + 1 IV(TOOBIG) = 0 IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 370 G01 = IV(NWTSTP) + N CALL V2AXY(N, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) IF (IV(IRC) .NE. 3) GO TO 390 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C CALL V2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1)) CALL V7VMP(N, V(TEMP1), V(TEMP1), D, -1) C C *** DO GRADIENT TESTS *** C IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) 1 GO TO 380 IF ( D7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 390 380 V(RADFAC) = V(INCFAC) C C *** UPDATE H, LOOP *** C 390 W1 = IV(NWTSTP) Z = IV(X0) L = IV(LMAT) IPI = IV(PERM) CALL V7IPR(N, IV(IPI), V(STEP1)) CALL V7IPR(N, IV(IPI), V(G01)) CALL W7ZBF(V(L), N, V(STEP1), V(W1), V(G01), V(Z)) C C ** USE THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH.. CALL L7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W1), 1 V(Z)) IV(1) = 2 GO TO 140 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 400 IV(1) = 64 GO TO 430 C C *** INCONSISTENT B *** C 410 IV(1) = 82 GO TO 430 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 420 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 430 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) GO TO 999 C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 440 DO 450 I = 1, N IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 450 CONTINUE C 999 RETURN C C *** LAST CARD OF RMNGB FOLLOWS *** END SUBROUTINE RMNH(D, FX, G, H, IV, LH, LIV, LV, N, V, X) C C *** CARRY OUT MNH (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING C *** HESSIAN MATRIX PROVIDED BY THE CALLER. C C *** PARAMETER DECLARATIONS *** C INTEGER LH, LIV, LV, N INTEGER IV(LIV) REAL D(N), FX, G(N), H(LH), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE. C IV... INTEGER VALUE ARRAY. C LH... LENGTH OF H = P*(P+1)/2. C LIV.. LENGTH OF IV (AT LEAST 60). C LV... LENGTH OF V (AT LEAST 78 + N*(N+21)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO MNH (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT MNH USES FOR STORING G AND H IS NOT NEEDED). C MOREOVER, COMPARED WITH MNH, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM MNH, IS NOT REFERENCED BY RMNH OR THE C SUBROUTINES IT CALLS. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL RMNH AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE C RMNH TO IGNORE FX AND TRY A SMALLER STEP. THE PARA- C METER NF THAT MNH PASSES TO CALCF (FOR POSSIBLE USE BY C CALCGH) IS A COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F C AT X, AND CALL RMNH AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D. C THE PARAMETER NF THAT MNH PASSES TO CALCG IS C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED, C THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN WHICH CASE C RMNH WILL RETURN WITH IV(1) = 65. C NOTE -- RMNH OVERWRITES H WITH THE LOWER TRIANGLE C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324 AND MCS-7906671. C C (SEE MNG AND MNH FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DUMMY, I, J, K, L, LSTGST, NN1O2, RSTRST, STEP1, 1 TEMP1, W1, X01 REAL T C C *** CONSTANTS *** C REAL ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, RLDST, V2NRM EXTERNAL A7SST, IVSET, D7TPR, D7DUP, G7QTS, ITSUM, PARCK, 1 RLDST, S7LVM, STOPX, V2AXY, V7CPY, V7SCP, V2NRM C C A7SST.... ASSESSES CANDIDATE STEP. C IVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C D7DUP.... UPDATES SCALE VECTOR D. C G7QTS.... COMPUTES OPTIMALLY LOCALLY CONSTRAINED STEP. C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C S7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER C TRIANGLE OF THE MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, 1 DTYPE, D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IRC, KAGQT, 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, 3 NFCALL, NFGCAL, NGCALL, NITER, PHMXFC, PREDUC, RADFAC, 4 RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, 5 STPPAR, TOOBIG, TUNER4, TUNER5, VNEED, W, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, KAGQT/33/, C 1 LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NITER/31/, C 3 RADINC/8/, RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/, C 4 TOOBIG/2/, VNEED/4/, W/34/, XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, KAGQT=33, 1 LMAT=42, MODE=35, MODEL=5, MXFCAL=17, MXITER=18, 2 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NITER=31, 3 RADINC=8, RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, 4 TOOBIG=2, VNEED=4, W=34, XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/, C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40, 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35, 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30) C/ C C/6 C DATA ONE/1.E+0/, ONEP2/1.2E+0/, ZERO/0.E+0/ C/7 PARAMETER (ONE=1.E+0, ONEP2=1.2E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 30 IF (I .EQ. 2) GO TO 40 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13) 1 IV(VNEED) = IV(VNEED) + N*(N+21)/2 + 7 CALL PARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 NN1O2 = N * (N + 1) / 2 IF (LH .GE. NN1O2) GO TO (220,220,220,220,220,220,160,120,160, 1 10,10,20), I IV(1) = 66 GO TO 400 C C *** STORAGE ALLOCATION *** C 10 IV(DTOL) = IV(LMAT) + NN1O2 IV(X0) = IV(DTOL) + 2*N IV(STEP) = IV(X0) + N IV(STLSTG) = IV(STEP) + N IV(DG) = IV(STLSTG) + N IV(W) = IV(DG) + N IV(NEXTV) = IV(W) + 4*N + 7 IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 V(RAD0) = ZERO V(STPPAR) = ZERO IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT)) K = IV(DTOL) IF (V(DTINIT) .GT. ZERO) CALL V7SCP(N, V(K), V(DTINIT)) K = K + N IF (V(D0INIT) .GT. ZERO) CALL V7SCP(N, V(K), V(D0INIT)) IV(1) = 1 GO TO 999 C 30 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 220 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 400 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 40 IF (IV(TOOBIG) .EQ. 0) GO TO 50 IV(1) = 65 GO TO 400 C C *** UPDATE THE SCALE VECTOR D *** C 50 DG1 = IV(DG) IF (IV(DTYPE) .LE. 0) GO TO 70 K = DG1 J = 0 DO 60 I = 1, N J = J + I V(K) = H(J) K = K + 1 60 CONTINUE CALL D7DUP(D, V(DG1), IV, LIV, LV, N, V) C C *** COMPUTE SCALED GRADIENT AND ITS NORM *** C 70 DG1 = IV(DG) K = DG1 DO 80 I = 1, N V(K) = G(I) / D(I) K = K + 1 80 CONTINUE V(DGNORM) = V2NRM(N, V(DG1)) C C *** COMPUTE SCALED HESSIAN *** C K = 1 DO 100 I = 1, N T = ONE / D(I) DO 90 J = 1, I H(K) = T * H(K) / D(J) K = K + 1 90 CONTINUE 100 CONTINUE C IF (IV(CNVCOD) .NE. 0) GO TO 390 IF (IV(MODE) .EQ. 0) GO TO 350 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 110 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) 120 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 130 IV(1) = 10 GO TO 400 C 130 IV(NITER) = K + 1 C C *** INITIALIZE FOR START OF NEXT ITERATION *** C DG1 = IV(DG) X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0 *** C CALL V7CPY(N, V(X01), X) C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 150 STEP1 = IV(STEP) K = STEP1 DO 140 I = 1, N V(K) = D(I) * V(K) K = K + 1 140 CONTINUE V(RADIUS) = V(RADFAC) * V2NRM(N, V(STEP1)) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 150 IF (.NOT. STOPX(DUMMY)) GO TO 170 IV(1) = 11 GO TO 180 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 160 IF (V(F) .GE. V(F0)) GO TO 170 V(RADFAC) = ONE K = IV(NITER) GO TO 130 C 170 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 190 IV(1) = 9 180 IF (V(F) .GE. V(F0)) GO TO 400 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 340 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 190 STEP1 = IV(STEP) DG1 = IV(DG) L = IV(LMAT) W1 = IV(W) CALL G7QTS(D, V(DG1), H, IV(KAGQT), V(L), N, V(STEP1), V, V(W1)) IF (IV(IRC) .NE. 6) GO TO 200 IF (IV(RESTOR) .NE. 2) GO TO 220 RSTRST = 2 GO TO 230 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 200 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 220 IF (IV(IRC) .NE. 5) GO TO 210 IF (V(RADFAC) .LE. ONE) GO TO 210 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 210 IF (IV(RESTOR) .NE. 2) GO TO 220 RSTRST = 0 GO TO 230 C C *** COMPUTE F(X0 + STEP) *** C 210 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 220 RSTRST = 3 230 X01 = IV(X0) V(RELDX) = RLDST(N, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (270, 240, 250, 260), I 240 CALL V7CPY(N, X, V(X01)) GO TO 270 250 CALL V7CPY(N, V(LSTGST), V(STEP1)) GO TO 270 260 CALL V7CPY(N, V(STEP1), V(LSTGST)) CALL V2AXY(N, X, ONE, V(STEP1), V(X01)) V(RELDX) = RLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 270 K = IV(IRC) GO TO (280,310,310,310,280,290,300,300,300,300,300,300,380,350), K C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 280 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 150 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 290 V(RADIUS) = V(LMAXS) GO TO 190 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 300 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 390 IF (IV(XIRC) .EQ. 14) GO TO 390 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 310 IF (IV(IRC) .NE. 3) GO TO 340 TEMP1 = LSTGST C C *** PREPARE FOR GRADIENT TESTS *** C *** SET TEMP1 = HESSIAN * STEP + G(X0) C *** = DIAG(D) * (H * STEP + G(X0)) C C USE X0 VECTOR AS TEMPORARY. K = X01 DO 320 I = 1, N V(K) = D(I) * V(STEP1) K = K + 1 STEP1 = STEP1 + 1 320 CONTINUE CALL S7LVM(N, V(TEMP1), H, V(X01)) DO 330 I = 1, N V(TEMP1) = D(I) * V(TEMP1) + G(I) TEMP1 = TEMP1 + 1 330 CONTINUE C C *** COMPUTE GRADIENT AND HESSIAN *** C 340 IV(NGCALL) = IV(NGCALL) + 1 IV(TOOBIG) = 0 IV(1) = 2 GO TO 999 C 350 IV(1) = 2 IF (IV(IRC) .NE. 3) GO TO 110 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C TEMP1 = IV(STLSTG) STEP1 = IV(STEP) C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C K = TEMP1 DO 360 I = 1, N V(K) = (V(K) - G(I)) / D(I) K = K + 1 360 CONTINUE C C *** DO GRADIENT TESTS *** C IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 370 IF ( D7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 110 370 V(RADFAC) = V(INCFAC) GO TO 110 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 380 IV(1) = 64 GO TO 400 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 390 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 400 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) C 999 RETURN C C *** LAST CARD OF RMNH FOLLOWS *** END SUBROUTINE RMNHB(B, D, FX, G, H, IV, LH, LIV, LV, N, V, X) C C *** CARRY OUT MNHB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS, C *** USING HESSIAN MATRIX PROVIDED BY THE CALLER. C C *** PARAMETER DECLARATIONS *** C INTEGER LH, LIV, LV, N INTEGER IV(LIV) REAL B(2,N), D(N), FX, G(N), H(LH), V(LV), X(N) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C FX... FUNCTION VALUE. C G.... GRADIENT VECTOR. C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE. C IV... INTEGER VALUE ARRAY. C LH... LENGTH OF H = P*(P+1)/2. C LIV.. LENGTH OF IV (AT LEAST 59 + 3*N). C LV... LENGTH OF V (AT LEAST 78 + N*(N+27)/2). C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G). C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO MNHB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE C THE PART OF V THAT MNHB USES FOR STORING G AND H IS NOT NEEDED). C MOREOVER, COMPARED WITH MNHB, IV(1) MAY HAVE THE TWO ADDITIONAL C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN C OUTPUT VALUE FROM MNHB, IS NOT REFERENCED BY RMNHB OR THE C SUBROUTINES IT CALLS. C C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE C AT X, AND CALL RMNHB AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE C RMNHB TO IGNORE FX AND TRY A SMALLER STEP. THE PARA- C METER NF THAT MNH PASSES TO CALCF (FOR POSSIBLE USE BY C CALCGH) IS A COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F C AT X, AND CALL RMNHB AGAIN, HAVING CHANGED NONE OF THE C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D. C THE PARAMETER NF THAT MNHB PASSES TO CALCG IS C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED, C THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH CASE C RMNHB WILL RETURN WITH IV(1) = 65. C NOTE -- RMNHB OVERWRITES H WITH THE LOWER TRIANGLE C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1. C. C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER, SPRING 1983). C C (SEE MNG AND MNH FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DG1, DUMMY, I, IPI, IPIV2, IPN, J, K, L, LSTGST, NN1O2, 1 RSTRST, STEP0, STEP1, TD1, TEMP0, TEMP1, TG1, W1, X01, X11 REAL GI, T, XI C C *** CONSTANTS *** C REAL NEGONE, ONE, ONEP2, ZERO C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, RLDST, V2NRM EXTERNAL A7SST, IVSET, D7TPR, D7DUP, G7QSB, I7PNVR, ITSUM, 1 PARCK, RLDST, S7IPR, S7LVM, STOPX, V2NRM, V2AXY, 2 V7CPY, V7IPR, V7SCP, V7VMP C C A7SST.... ASSESSES CANDIDATE STEP. C IVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C D7DUP.... UPDATES SCALE VECTOR D. C G7QSB... COMPUTES APPROXIMATE OPTIMAL BOUNDED STEP. C I7PNVR... INVERTS PERMUTATION ARRAY. C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C S7IPR... APPLIES PERMUTATION TO LOWER TRIANG. OF SYM. MATRIX. C S7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER C TRIANGLE OF THE MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7IPR... APPLIES PERMUTATION TO VECTOR. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V7VMP... MULTIPLIES (OR DIVIDES) TWO VECTORS COMPONENTWISE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, DTYPE, 1 D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IVNEED, IRC, KAGQT, 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, N0, NC, 3 NEXTIV, NEXTV, NFCALL, NFGCAL, NGCALL, NITER, PERM, 4 PHMXFC, PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, 5 RESTOR, STEP, STGLIM, STPPAR, TOOBIG, TUNER4, TUNER5, 6 VNEED, W, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT NC AND N0 ARE STORED IN IV(G0) AND IV(STLSTG) RESP.) C C/6 C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, IVNEED/3/, C 1 KAGQT/33/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, C 2 MXITER/18/, N0/41/, NC/48/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, C 3 NFGCAL/7/, NGCALL/30/, NITER/31/, PERM/58/, RADINC/8/, C 4 RESTOR/9/, STEP/40/, STGLIM/11/, TOOBIG/2/, VNEED/4/, W/34/, C 5 XIRC/13/, X0/43/ C/7 PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, IVNEED=3, 1 KAGQT=33, LMAT=42, MODE=35, MODEL=5, MXFCAL=17, 2 MXITER=18, N0=41, NC=48, NEXTIV=46, NEXTV=47, NFCALL=6, 3 NFGCAL=7, NGCALL=30, NITER=31, PERM=58, RADINC=8, 4 RESTOR=9, STEP=40, STGLIM=11, TOOBIG=2, VNEED=4, W=34, 5 XIRC=13, X0=43) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/, C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/, C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/ C/7 PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40, 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35, 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8, 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30) C/ C C/6 C DATA NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, ZERO/0.E+0/ C/7 PARAMETER (NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V) IF (IV(1) .LT. 12) GO TO 10 IF (IV(1) .GT. 13) GO TO 10 IV(VNEED) = IV(VNEED) + N*(N+27)/2 + 7 IV(IVNEED) = IV(IVNEED) + 3*N 10 CALL PARCK(2, D, IV, LIV, LV, N, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 NN1O2 = N * (N + 1) / 2 IF (LH .GE. NN1O2) GO TO (250,250,250,250,250,250,190,150,190, 1 20,20,30), I IV(1) = 81 GO TO 440 C C *** STORAGE ALLOCATION *** C 20 IV(DTOL) = IV(LMAT) + NN1O2 IV(X0) = IV(DTOL) + 2*N IV(STEP) = IV(X0) + 2*N IV(DG) = IV(STEP) + 3*N IV(W) = IV(DG) + 2*N IV(NEXTV) = IV(W) + 4*N + 7 IV(NEXTIV) = IV(PERM) + 3*N IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(MODEL) = 1 IV(STGLIM) = 1 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(RADINC) = 0 IV(NC) = N V(RAD0) = ZERO V(STPPAR) = ZERO IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT)) K = IV(DTOL) IF (V(DTINIT) .GT. ZERO) CALL V7SCP(N, V(K), V(DTINIT)) K = K + N IF (V(D0INIT) .GT. ZERO) CALL V7SCP(N, V(K), V(D0INIT)) C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(PERM) DO 40 I = 1, N IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 420 40 CONTINUE C C *** GET INITIAL FUNCTION VALUE *** C IV(1) = 1 GO TO 450 C 50 V(F) = FX IF (IV(MODE) .GE. 0) GO TO 250 V(F0) = FX IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 440 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 440 C C *** UPDATE THE SCALE VECTOR D *** C 70 DG1 = IV(DG) IF (IV(DTYPE) .LE. 0) GO TO 90 K = DG1 J = 0 DO 80 I = 1, N J = J + I V(K) = H(J) K = K + 1 80 CONTINUE CALL D7DUP(D, V(DG1), IV, LIV, LV, N, V) C C *** COMPUTE SCALED GRADIENT AND ITS NORM *** C 90 DG1 = IV(DG) CALL V7VMP(N, V(DG1), G, D, -1) C C *** COMPUTE SCALED HESSIAN *** C K = 1 DO 110 I = 1, N T = ONE / D(I) DO 100 J = 1, I H(K) = T * H(K) / D(J) K = K + 1 100 CONTINUE 110 CONTINUE C C *** CHOOSE INITIAL PERMUTATION *** C IPI = IV(PERM) IPN = IPI + N IPIV2 = IPN - 1 C *** INVERT OLD PERMUTATION ARRAY *** CALL I7PNVR(N, IV(IPN), IV(IPI)) K = IV(NC) DO 130 I = 1, N IF (B(1,I) .GE. B(2,I)) GO TO 120 XI = X(I) GI = G(I) IF (XI .LE. B(1,I) .AND. GI .GT. ZERO) GO TO 120 IF (XI .GE. B(2,I) .AND. GI .LT. ZERO) GO TO 120 IV(IPI) = I IPI = IPI + 1 J = IPIV2 + I C *** DISALLOW CONVERGENCE IF X(I) HAS JUST BEEN FREED *** IF (IV(J) .GT. K) IV(CNVCOD) = 0 GO TO 130 120 IPN = IPN - 1 IV(IPN) = I 130 CONTINUE IV(NC) = IPN - IV(PERM) C C *** PERMUTE SCALED GRADIENT AND HESSIAN ACCORDINGLY *** C IPI = IV(PERM) CALL S7IPR(N, IV(IPI), H) CALL V7IPR(N, IV(IPI), V(DG1)) V(DGNORM) = ZERO IF (IV(NC) .GT. 0) V(DGNORM) = V2NRM(IV(NC), V(DG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 430 IF (IV(MODE) .EQ. 0) GO TO 380 C C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) *** C V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 140 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) 150 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 160 IV(1) = 10 GO TO 440 C 160 IV(NITER) = K + 1 C C *** INITIALIZE FOR START OF NEXT ITERATION *** C X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(KAGQT) = -1 C C *** COPY X TO X0 *** C CALL V7CPY(N, V(X01), X) C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 180 STEP1 = IV(STEP) K = STEP1 DO 170 I = 1, N V(K) = D(I) * V(K) K = K + 1 170 CONTINUE T = V(RADFAC) * V2NRM(N, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 180 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 210 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 190 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 160 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220 IV(1) = 9 210 IF (V(F) .GE. V(F0)) GO TO 440 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 370 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 220 STEP1 = IV(STEP) L = IV(LMAT) W1 = IV(W) IPI = IV(PERM) IPN = IPI + N IPIV2 = IPN + N TG1 = IV(DG) TD1 = TG1 + N X01 = IV(X0) X11 = X01 + N CALL G7QSB(B, D, H, G, IV(IPI), IV(IPN), IV(IPIV2), IV(KAGQT), 1 V(L), LV, N, IV(N0), IV(NC), V(STEP1), V(TD1), V(TG1), 2 V, V(W1), V(X11), V(X01)) IF (IV(IRC) .NE. 6) GO TO 230 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 2 GO TO 260 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 230 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 250 IF (IV(IRC) .NE. 5) GO TO 240 IF (V(RADFAC) .LE. ONE) GO TO 240 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 250 RSTRST = 0 GO TO 260 C C *** COMPUTE F(X0 + STEP) *** C 240 CALL V2AXY(N, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 450 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 250 RSTRST = 3 260 X01 = IV(X0) V(RELDX) = RLDST(N, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = STEP1 + 2*N I = IV(RESTOR) + 1 GO TO (300, 270, 280, 290), I 270 CALL V7CPY(N, X, V(X01)) GO TO 300 280 CALL V7CPY(N, V(LSTGST), X) GO TO 300 290 CALL V7CPY(N, X, V(LSTGST)) CALL V2AXY(N, V(STEP1), NEGONE, V(X01), X) V(RELDX) = RLDST(N, D, X, V(X01)) IV(RESTOR) = RSTRST C 300 K = IV(IRC) GO TO (310,340,340,340,310,320,330,330,330,330,330,330,410,380), K C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 310 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 180 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST. C 320 V(RADIUS) = V(LMAXS) GO TO 220 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 330 IV(CNVCOD) = K - 4 IF (V(F) .GE. V(F0)) GO TO 430 IF (IV(XIRC) .EQ. 14) GO TO 430 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 340 IF (IV(IRC) .NE. 3) GO TO 370 TEMP1 = LSTGST C C *** PREPARE FOR GRADIENT TESTS *** C *** SET TEMP1 = HESSIAN * STEP + G(X0) C *** = DIAG(D) * (H * STEP + G(X0)) C K = TEMP1 STEP0 = STEP1 - 1 IPI = IV(PERM) DO 350 I = 1, N J = IV(IPI) IPI = IPI + 1 STEP1 = STEP0 + J V(K) = D(J) * V(STEP1) K = K + 1 350 CONTINUE C USE X0 VECTOR AS TEMPORARY. CALL S7LVM(N, V(X01), H, V(TEMP1)) TEMP0 = TEMP1 - 1 IPI = IV(PERM) DO 360 I = 1, N J = IV(IPI) IPI = IPI + 1 TEMP1 = TEMP0 + J V(TEMP1) = D(J) * V(X01) + G(J) X01 = X01 + 1 360 CONTINUE C C *** COMPUTE GRADIENT AND HESSIAN *** C 370 IV(NGCALL) = IV(NGCALL) + 1 IV(TOOBIG) = 0 IV(1) = 2 GO TO 450 C 380 IV(1) = 2 IF (IV(IRC) .NE. 3) GO TO 140 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C STEP1 = IV(STEP) C *** TEMP1 = STLSTG *** TEMP1 = STEP1 + 2*N C C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) *** C K = TEMP1 DO 390 I = 1, N V(K) = (V(K) - G(I)) / D(I) K = K + 1 390 CONTINUE C C *** DO GRADIENT TESTS *** C IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 400 IF ( D7TPR(N, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 140 400 V(RADFAC) = V(INCFAC) GO TO 140 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 410 IV(1) = 64 GO TO 440 C C *** INCONSISTENT B *** C 420 IV(1) = 82 GO TO 440 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 430 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 440 CALL ITSUM(D, G, IV, LIV, LV, N, V, X) GO TO 999 C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 450 DO 460 I = 1, N IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 460 CONTINUE C 999 RETURN C C *** LAST CARD OF RMNHB FOLLOWS *** END SUBROUTINE RN2G(D, DR, IV, LIV, LV, N, ND, N1, N2, P, R, 1 RD, V, X) C C *** REVISED ITERATION DRIVER FOR NL2SOL (VERSION 2.3) *** C INTEGER LIV, LV, N, ND, N1, N2, P INTEGER IV(LIV) REAL D(P), DR(ND,P), R(ND), RD(ND), V(LV), X(P) C C-------------------------- PARAMETER USAGE -------------------------- C C D........ SCALE VECTOR. C DR....... DERIVATIVES OF R AT X. C IV....... INTEGER VALUES ARRAY. C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST P + 82. C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+16). C N........ TOTAL NUMBER OF RESIDUALS. C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL. C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C R........ RESIDUALS. C RD....... RD(I) = SQRT(G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN C IV(RDREQ) IS NONZERO. RN2G SETS IV(REGD) = 1 IF RD C IS SUCCESSFULLY COMPUTED, TO 0 IF NO ATTEMPT WAS MADE C TO COMPUTE IT, AND TO -1 IF H (THE FINITE-DIFFERENCE HESSIAN) C WAS INDEFINITE. IF ND .GE. N, THEN RD IS ALSO USED AS C TEMPORARY STORAGE. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** DISCUSSION *** C C NOTE... NL2SOL AND NL2ITR (MENTIONED BELOW) ARE DESCRIBED IN C ACM TRANS. MATH. SOFTWARE, VOL. 7, PP. 369-383 (AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, D.M. GAY, C AND R.E. WELSCH). C C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR C LEAST SQUARES PROBLEMS. WHEN ND = N, IT IS SIMILAR TO NL2ITR C (WITH J = DR), EXCEPT THAT R(X) AND DR(X) NEED NOT BE INITIALIZED C WHEN RN2G IS CALLED WITH IV(1) = 0 OR 12. RN2G ALSO ALLOWS C R AND DR TO BE SUPPLIED ROW-WISE -- JUST SET ND = 1 AND CALL C RN2G ONCE FOR EACH ROW WHEN PROVIDING RESIDUALS AND JACOBIANS. C ANOTHER NEW FEATURE IS THAT CALLING RN2G WITH IV(1) = 13 C CAUSES STORAGE ALLOCATION ONLY TO BE PERFORMED -- ON RETURN, SUCH C COMPONENTS AS IV(G) (THE FIRST SUBSCRIPT IN G OF THE GRADIENT) C AND IV(S) (THE FIRST SUBSCRIPT IN V OF THE S LOWER TRIANGLE OF C THE S MATRIX) WILL HAVE BEEN SET (UNLESS LIV OR LV IS TOO SMALL), C AND IV(1) WILL HAVE BEEN SET TO 14. CALLING RN2G WITH IV(1) = 14 C CAUSES EXECUTION OF THE ALGORITHM TO BEGIN UNDER THE ASSUMPTION C THAT STORAGE HAS BEEN ALLOCATED. C C *** SUPPLYING R AND DR *** C C RN2G USES IV AND V IN THE SAME WAY AS NL2SOL, WITH A SMALL C NUMBER OF OBVIOUS CHANGES. ONE DIFFERENCE BETWEEN RN2G AND C NL2ITR IS THAT INITIAL FUNCTION AND GRADIENT INFORMATION NEED NOT C BE SUPPLIED IN THE VERY FIRST CALL ON RN2G, THE ONE WITH C IV(1) = 0 OR 12. ANOTHER DIFFERENCE IS THAT RN2G RETURNS WITH C IV(1) = -2 WHEN IT WANTS ANOTHER LOOK AT THE OLD JACOBIAN MATRIX C AND THE CURRENT RESIDUAL -- THE ONE CORRESPONDING TO X AND C IV(NFGCAL). IT THEN RETURNS WITH IV(1) = -3 WHEN IT WANTS TO SEE C BOTH THE NEW RESIDUAL AND THE NEW JACOBIAN MATRIX AT ONCE. NOTE C THAT IV(NFGCAL) = IV(7) CONTAINS THE VALUE THAT IV(NFCALL) = IV(6) C HAD WHEN THE CURRENT RESIDUAL WAS EVALUATED. ALSO NOTE THAT THE C VALUE OF X CORRESPONDING TO THE OLD JACOBIAN MATRIX IS STORED IN C V, STARTING AT V(IV(X0)) = V(IV(43)). C ANOTHER NEW RETURN... RN2G IV(1) = -1 WHEN IT WANTS BOTH THE C RESIDUAL AND THE JACOBIAN TO BE EVALUATED AT X. C A NEW RESIDUAL VECTOR MUST BE SUPPLIED WHEN RN2G RETURNS WITH C IV(1) = 1 OR -1. THIS TAKES THE FORM OF VALUES OF R(I,X) PASSED C IN R(I-N1+1), I = N1(1)N2. YOU MAY PASS ALL THESE VALUES AT ONCE C (I.E., N1 = 1 AND N2 = N) OR IN PIECES BY MAKING SEVERAL CALLS ON C RN2G. EACH TIME RN2G RETURNS WITH IV(1) = 1, N1 WILL HAVE C BEEN SET TO THE INDEX OF THE NEXT RESIDUAL THAT RN2G EXPECTS TO C SEE, AND N2 WILL BE SET TO THE INDEX OF THE HIGHEST RESIDUAL THAT C COULD BE GIVEN ON THE NEXT CALL, I.E., N2 = N1 + ND - 1. (THUS C WHEN RN2G FIRST RETURNS WITH IV(1) = 1 FOR A NEW X, IT WILL C HAVE SET N1 TO 1 AND N2 TO MIN(ND,N).) THE CALLER MAY PROVIDE C FEWER THAN N2-N1+1 RESIDUALS ON THE NEXT CALL BY SETTING N2 TO C A SMALLER VALUE. RN2G ASSUMES IT HAS SEEN ALL THE RESIDUALS C FOR THE CURRENT X WHEN IT IS CALLED WITH N2 .GE. N. C EXAMPLE... SUPPOSE N = 80 AND THAT R IS TO BE PASSED IN 8 C BLOCKS OF SIZE 10. THE FOLLOWING CODE WOULD DO THE JOB. C C N = 80 C ND = 10 C ... C DO 10 K = 1, 8 C *** COMPUTE R(I,X) FOR I = 10*K-9 TO 10*K *** C *** AND STORE THEM IN R(1),...,R(10) *** C CALL RN2G(..., R, ...) C 10 CONTINUE C C THE SITUATION IS SIMILAR WHEN GRADIENT INFORMATION IS C REQUIRED, I.E., WHEN RN2G RETURNS WITH IV(1) = 2, -1, OR -2. C NOTE THAT RN2G OVERWRITES R, BUT THAT IN THE SPECIAL CASE OF C N1 = 1 AND N2 = N ON PREVIOUS CALLS, RN2G NEVER RETURNS WITH C IV(1) = -2. IT SHOULD BE CLEAR THAT THE PARTIAL DERIVATIVE OF C R(I,X) WITH RESPECT TO X(L) IS TO BE STORED IN DR(I-N1+1,L), C L = 1(1)P, I = N1(1)N2. IT IS ESSENTIAL THAT R(I) AND DR(I,L) C ALL CORRESPOND TO THE SAME RESIDUALS WHEN IV(1) = -1 OR -2. C C *** COVARIANCE MATRIX *** C C IV(RDREQ) = IV(57) TELLS WHETHER TO COMPUTE A COVARIANCE C MATRIX AND/OR REGRESSION DIAGNOSTICS... 0 MEANS NEITHER, C 1 MEANS COVARIANCE MATRIX ONLY, 2 MEANS REG. DIAGNOSTICS ONLY, C 3 MEANS BOTH. AS WITH NL2SOL, IV(COVREQ) = IV(15) TELLS WHAT C HESSIAN APPROXIMATION TO USE IN THIS COMPUTING. C C *** REGRESSION DIAGNOSTICS *** C C SEE THE COMMENTS IN SUBROUTINE N2G. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS, MOD C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL C7VFN, IVSET, D7TPR, D7UPD, G7LIT, ITSUM, L7VML, 1 N2CVP, N2LRD, Q7APL, Q7RAD, V7CPY, V7SCP, V2NRM C C C7VFN... FINISHES COVARIANCE COMPUTATION. C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C D7UPD... UPDATES SCALE VECTOR D. C G7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM. C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C N2CVP... PRINTS COVARIANCE MATRIX. C N2LRD... COMPUTES REGRESSION DIAGNOSTICS. C Q7APL... APPLIES QR TRANSFORMATIONS STORED BY Q7RAD. C Q7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C INTEGER G1, GI, I, IV1, IVMODE, JTOL1, K, L, LH, NN, QTR1, 1 RMAT1, YI, Y1 REAL T C REAL HALF, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COVMAT, COVREQ, DINIT, DTYPE, DTINIT, D0INIT, F, 1 FDH, G, H, IPIVOT, IVNEED, JCN, JTOL, LMAT, MODE, 2 NEXTIV, NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, 3 NGCALL, NGCOV, QTR, RDREQ, REGD, RESTOR, RLIMIT, RMAT, 4 TOOBIG, VNEED, Y C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DTYPE/16/, FDH/74/, C 1 G/28/, H/56/, IPIVOT/76/, IVNEED/3/, JCN/66/, JTOL/59/, C 2 LMAT/42/, MODE/35/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, C 3 NFCOV/52/, NF0/68/, NF00/81/, NF1/69/, NFGCAL/7/, NGCALL/30/, C 4 NGCOV/53/, QTR/77/, RESTOR/9/, RMAT/78/, RDREQ/57/, REGD/67/, C 5 TOOBIG/2/, VNEED/4/, Y/48/ C/7 PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DTYPE=16, FDH=74, 1 G=28, H=56, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59, 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6, 3 NFCOV=52, NF0=68, NF00=81, NF1=69, NFGCAL=7, NGCALL=30, 4 NGCOV=53, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, REGD=67, 5 TOOBIG=2, VNEED=4, Y=48) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/ C/7 PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) C/ C/6 C DATA HALF/0.5E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 NN = N2 - N1 + 1 IV(RESTOR) = 0 I = IV1 + 4 IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I IF (I .NE. 5) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LE. 0) GO TO 210 IF (P .LE. 0) GO TO 210 IF (N .LE. 0) GO TO 210 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 300 IF (IV1 .LT. 12) GO TO 40 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 20 IV(IVNEED) = IV(IVNEED) + P IV(VNEED) = IV(VNEED) + P*(P+13)/2 20 CALL G7LIT(D, X, IV, LIV, LV, P, P, V, X, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IPIVOT) = IV(NEXTIV) IV(NEXTIV) = IV(IPIVOT) + P IV(Y) = IV(NEXTV) IV(G) = IV(Y) + P IV(JCN) = IV(G) + P IV(RMAT) = IV(JCN) + P IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + P IV(NEXTV) = IV(JTOL) + 2*P IF (IV1 .EQ. 13) GO TO 999 C 30 JTOL1 = IV(JTOL) IF (V(DINIT) .GE. ZERO) CALL V7SCP(P, D, V(DINIT)) IF (V(DTINIT) .GT. ZERO) CALL V7SCP(P, V(JTOL1), V(DTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL V7SCP(P, V(I), V(D0INIT)) IV(NF0) = 0 IV(NF1) = 0 IF (ND .GE. N) GO TO 40 C C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE C G1 = IV(G) Y1 = IV(Y) CALL G7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 1) GO TO 220 V(F) = ZERO CALL V7SCP(P, V(G1), ZERO) IV(1) = -1 QTR1 = IV(QTR) CALL V7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 RMAT1 = IV(RMAT) GO TO 100 C 40 G1 = IV(G) Y1 = IV(Y) CALL G7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 220 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 260 IF (IV(RESTOR) .NE. 2) GO TO 260 IV(NF0) = IV(NF1) CALL V7CPY(N, RD, R) IV(REGD) = 0 GO TO 260 C 60 CALL V7SCP(P, V(G1), ZERO) IF (IV(MODE) .GT. 0) GO TO 230 RMAT1 = IV(RMAT) QTR1 = IV(QTR) CALL V7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 IF (ND .LT. N) GO TO 90 IF (N1 .NE. 1) GO TO 90 IF (IV(MODE) .LT. 0) GO TO 100 IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70 IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90 CALL V7CPY(N, R, RD) GO TO 80 70 CALL V7CPY(N, RD, R) 80 CALL Q7APL(ND, N, P, DR, RD, 0) CALL L7VML(P, V(Y1), V(RMAT1), RD) GO TO 110 C 90 IV(1) = -2 IF (IV(MODE) .LT. 0) IV(1) = -1 100 CALL V7SCP(P, V(Y1), ZERO) 110 CALL V7SCP(LH, V(RMAT1), ZERO) GO TO 260 C C *** COMPUTE F(X) *** C 120 T = V2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 200 V(F) = V(F) + HALF * T**2 IF (N2 .LT. N) GO TO 270 IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL) GO TO 40 C C *** COMPUTE Y *** C 130 Y1 = IV(Y) YI = Y1 DO 140 L = 1, P V(YI) = V(YI) + D7TPR(NN, DR(1,L), R) YI = YI + 1 140 CONTINUE IF (N2 .LT. N) GO TO 270 IV(1) = 2 IF (N1 .GT. 1) IV(1) = -3 GO TO 260 C C *** COMPUTE GRADIENT INFORMATION *** C 150 IF (IV(MODE) .GT. P) GO TO 240 G1 = IV(G) IVMODE = IV(MODE) IF (IVMODE .LT. 0) GO TO 170 IF (IVMODE .EQ. 0) GO TO 180 IV(1) = 2 C C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) *** C GI = G1 DO 160 L = 1, P V(GI) = V(GI) + D7TPR(NN, R, DR(1,L)) GI = GI + 1 160 CONTINUE GO TO 190 C C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N *** C 170 IF (N .LE. ND) GO TO 180 T = V2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 200 V(F) = V(F) + HALF * T**2 C C *** UPDATE D IF DESIRED *** C 180 IF (IV(DTYPE) .GT. 0) 1 CALL D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** COMPUTE RMAT AND QTR *** C QTR1 = IV(QTR) RMAT1 = IV(RMAT) CALL Q7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R) IV(NF1) = 0 C 190 IF (N2 .LT. N) GO TO 270 IF (IVMODE .GT. 0) GO TO 40 IV(NF00) = IV(NFGCAL) C C *** COMPUTE G FROM RMAT AND QTR *** C CALL L7VML(P, V(G1), V(RMAT1), V(QTR1)) IV(1) = 2 IF (IVMODE .EQ. 0) GO TO 40 IF (N .LE. ND) GO TO 40 C C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT C Y1 = IV(Y) IV(1) = 1 CALL G7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 2) GO TO 220 GO TO 40 C C *** MISC. DETAILS *** C C *** X IS OUT OF RANGE (OVERSIZE STEP) *** C 200 IV(TOOBIG) = 1 GO TO 40 C C *** BAD N, ND, OR P *** C 210 IV(1) = 66 GO TO 300 C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 220 IF (IV(COVMAT) .NE. 0) GO TO 290 IF (IV(REGD) .NE. 0) GO TO 290 C C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE *** C K = IV(FDH) IF (K .LE. 0) GO TO 280 IF (IV(RDREQ) .LE. 0) GO TO 290 C C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF C DESIRED *** C I = 0 IF (MOD(IV(RDREQ),4) .GE. 2) I = 1 IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .LE. 1) I = I+2 IF (I .EQ. 0) GO TO 250 IV(MODE) = P + I IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 IV(CNVCOD) = IV(1) IF (I .LT. 2) GO TO 230 L = IABS(IV(H)) CALL V7SCP(LH, V(L), ZERO) 230 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 GO TO 260 C 240 L = IV(LMAT) CALL N2LRD(DR, IV, V(L), LH, LIV, LV, ND, NN, P, R, RD, V) IF (N2 .LT. N) GO TO 270 IF (N1 .GT. 1) GO TO 250 C C *** ENSURE WE CAN RESTART -- AND MAKE RETURN STATE OF DR C *** INDEPENDENT OF WHETHER REGRESSION DIAGNOSTICS ARE COMPUTED. C *** USE STEP VECTOR (ALLOCATED BY G7LIT) FOR SCRATCH. C RMAT1 = IV(RMAT) CALL V7SCP(LH, V(RMAT1), ZERO) CALL Q7RAD(NN, ND, P, R, .FALSE., V(RMAT1), DR, R) IV(NF1) = 0 C C *** FINISH COMPUTING COVARIANCE *** C 250 L = IV(LMAT) CALL C7VFN(IV, V(L), LH, LIV, LV, N, P, V) GO TO 290 C C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION *** C 260 N2 = 0 270 N1 = N2 + 1 N2 = N2 + ND IF (N2 .GT. N) N2 = N GO TO 999 C C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN *** C 280 IV(COVMAT) = K IV(REGD) = K C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 290 G1 = IV(G) 300 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X) IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0) 1 CALL N2CVP(IV, LIV, LV, P, V) C 999 RETURN C *** LAST LINE OF RN2G FOLLOWS *** END SUBROUTINE RN2GB(B, D, DR, IV, LIV, LV, N, ND, N1, N2, P, R, 1 RD, V, X) C C *** REVISED ITERATION DRIVER FOR NL2SOL WITH SIMPLE BOUNDS *** C INTEGER LIV, LV, N, ND, N1, N2, P INTEGER IV(LIV) REAL B(2,P), D(P), DR(ND,P), R(ND), RD(ND), V(LV), 1 X(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B........ BOUNDS ON X. C D........ SCALE VECTOR. C DR....... DERIVATIVES OF R AT X. C IV....... INTEGER VALUES ARRAY. C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82. C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20). C N........ TOTAL NUMBER OF RESIDUALS. C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL. C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C R........ RESIDUALS. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** DISCUSSION *** C C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR C LEAST SQUARES PROBLEMS. IT IS SIMILAR TO RN2G, EXCEPT THAT C THIS ROUTINE ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL IVSET, D7TPR, D7UPD, G7ITB, ITSUM, L7VML, Q7APL, 1 Q7RAD, R7TVM, V7CPY, V7SCP, V2NRM C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C D7UPD... UPDATES SCALE VECTOR D. C G7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM. C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C Q7APL... APPLIES QR TRANSFORMATIONS STORED BY Q7RAD. C Q7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION. C R7TVM... MULT. VECTOR BY TRANS. OF UPPER TRIANG. MATRIX FROM QR FACT. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C C C *** LOCAL VARIABLES *** C INTEGER G1, GI, I, IV1, IVMODE, JTOL1, L, LH, NN, QTR1, 1 RD1, RMAT1, YI, Y1 REAL T C REAL HALF, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, G, JCN, JTOL, MODE, 1 NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, QTR, RDREQ, 1 REGD, RESTOR, RLIMIT, RMAT, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA DTYPE/16/, G/28/, JCN/66/, JTOL/59/, MODE/35/, NEXTV/47/, C 1 NF0/68/, NF00/81/, NF1/69/, NFCALL/6/, NFCOV/52/, NFGCAL/7/, C 2 QTR/77/, RDREQ/57/, RESTOR/9/, REGD/67/, RMAT/78/, TOOBIG/2/, C 3 VNEED/4/ C/7 PARAMETER (DTYPE=16, G=28, JCN=66, JTOL=59, MODE=35, NEXTV=47, 1 NF0=68, NF00=81, NF1=69, NFCALL=6, NFCOV=52, NFGCAL=7, 2 QTR=77, RDREQ=57, RESTOR=9, REGD=67, RMAT=78, TOOBIG=2, 3 VNEED=4) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/ C/7 PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) C/ C/6 C DATA HALF/0.5E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 NN = N2 - N1 + 1 IV(RESTOR) = 0 I = IV1 + 4 IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I IF (I .NE. 5) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LE. 0) GO TO 220 IF (P .LE. 0) GO TO 220 IF (N .LE. 0) GO TO 220 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 270 IF (IV1 .LT. 12) GO TO 40 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 20 IV(VNEED) = IV(VNEED) + P*(P+15)/2 20 CALL G7ITB(B, D, X, IV, LIV, LV, P, P, V, X, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) IV(JCN) = IV(G) + 2*P IV(RMAT) = IV(JCN) + P IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + 2*P IV(NEXTV) = IV(JTOL) + 2*P C *** TURN OFF COVARIANCE COMPUTATION *** IV(RDREQ) = 0 IF (IV1 .EQ. 13) GO TO 999 C 30 JTOL1 = IV(JTOL) IF (V(DINIT) .GE. ZERO) CALL V7SCP(P, D, V(DINIT)) IF (V(DTINIT) .GT. ZERO) CALL V7SCP(P, V(JTOL1), V(DTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL V7SCP(P, V(I), V(D0INIT)) IV(NF0) = 0 IV(NF1) = 0 IF (ND .GE. N) GO TO 40 C C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE C G1 = IV(G) Y1 = G1 + P CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 1) GO TO 260 V(F) = ZERO CALL V7SCP(P, V(G1), ZERO) IV(1) = -1 QTR1 = IV(QTR) CALL V7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 RMAT1 = IV(RMAT) GO TO 100 C 40 G1 = IV(G) Y1 = G1 + P CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 260 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 240 IV(NF0) = IV(NF1) CALL V7CPY(N, RD, R) IV(REGD) = 0 GO TO 240 C 60 CALL V7SCP(P, V(G1), ZERO) IF (IV(MODE) .GT. 0) GO TO 230 RMAT1 = IV(RMAT) QTR1 = IV(QTR) RD1 = QTR1 + P CALL V7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 IF (ND .LT. N) GO TO 90 IF (N1 .NE. 1) GO TO 90 IF (IV(MODE) .LT. 0) GO TO 100 IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70 IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90 CALL V7CPY(N, R, RD) GO TO 80 70 CALL V7CPY(N, RD, R) 80 CALL Q7APL(ND, N, P, DR, RD, 0) CALL R7TVM(ND, MIN0(N,P), V(Y1), V(RD1), DR, RD) IV(REGD) = 0 GO TO 110 C 90 IV(1) = -2 IF (IV(MODE) .LT. 0) IV(1) = -3 100 CALL V7SCP(P, V(Y1), ZERO) 110 CALL V7SCP(LH, V(RMAT1), ZERO) GO TO 240 C C *** COMPUTE F(X) *** C 120 T = V2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 210 V(F) = V(F) + HALF * T**2 IF (N2 .LT. N) GO TO 250 IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL) GO TO 40 C C *** COMPUTE Y *** C 130 Y1 = IV(G) + P YI = Y1 DO 140 L = 1, P V(YI) = V(YI) + D7TPR(NN, DR(1,L), R) YI = YI + 1 140 CONTINUE IF (N2 .LT. N) GO TO 250 IV(1) = 2 IF (N1 .GT. 1) IV(1) = -3 GO TO 240 C C *** COMPUTE GRADIENT INFORMATION *** C 150 G1 = IV(G) IVMODE = IV(MODE) IF (IVMODE .LT. 0) GO TO 170 IF (IVMODE .EQ. 0) GO TO 180 IV(1) = 2 C C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) *** C GI = G1 DO 160 L = 1, P V(GI) = V(GI) + D7TPR(NN, R, DR(1,L)) GI = GI + 1 160 CONTINUE GO TO 200 C C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N *** C 170 IF (N .LE. ND) GO TO 180 T = V2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 210 V(F) = V(F) + HALF * T**2 C C *** UPDATE D IF DESIRED *** C 180 IF (IV(DTYPE) .GT. 0) 1 CALL D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** COMPUTE RMAT AND QTR *** C QTR1 = IV(QTR) RMAT1 = IV(RMAT) CALL Q7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R) IV(NF1) = 0 IF (N1 .GT. 1) GO TO 200 IF (N2 .LT. N) GO TO 250 C C *** SAVE DIAGONAL OF R FOR COMPUTING Y LATER *** C RD1 = QTR1 + P L = RMAT1 - 1 DO 190 I = 1, P L = L + I V(RD1) = V(L) RD1 = RD1 + 1 190 CONTINUE C 200 IF (N2 .LT. N) GO TO 250 IF (IVMODE .GT. 0) GO TO 40 IV(NF00) = IV(NFGCAL) C C *** COMPUTE G FROM RMAT AND QTR *** C CALL L7VML(P, V(G1), V(RMAT1), V(QTR1)) IV(1) = 2 IF (IVMODE .EQ. 0) GO TO 40 IF (N .LE. ND) GO TO 40 C C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT C Y1 = G1 + P IV(1) = 1 CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 2) GO TO 260 GO TO 40 C C *** MISC. DETAILS *** C C *** X IS OUT OF RANGE (OVERSIZE STEP) *** C 210 IV(TOOBIG) = 1 GO TO 40 C C *** BAD N, ND, OR P *** C 220 IV(1) = 66 GO TO 270 C C *** RECORD EXTRA EVALUATIONS FOR FINITE-DIFFERENCE HESSIAN *** C 230 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 C C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION *** C 240 N2 = 0 250 N1 = N2 + 1 N2 = N2 + ND IF (N2 .GT. N) N2 = N GO TO 999 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 260 G1 = IV(G) 270 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X) C 999 RETURN C *** LAST CARD OF RN2GB FOLLOWS *** END SUBROUTINE RNSG(A, ALF, C, DA, IN, IV, L, L1, LA, LIV, LV, 1 N, NDA, P, V, Y) C C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES. C C *** PARAMETER DECLARATIONS *** C INTEGER L, L1, LA, LIV, LV, N, NDA, P INTEGER IN(2,NDA), IV(LIV) C DIMENSION UIPARM(*) REAL A(LA,L1), ALF(P), C(L), DA(LA,NDA), V(LV), Y(N) C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), RNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )). C I=1 I I C C THE (L+1)ST TERM IS OPTIONAL. C C C *** PARAMETERS *** C C A (IN) MATRIX PHI(ALF,T) OF THE MODEL. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C C (OUT) LINEAR PARAMETERS (ESTIMATED). C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS C OF ALF, AS SPECIFIED BY THE IN ARRAY... C IN (IN) WHEN RNSG IS CALLED WITH IV(1) = 2 OR -2, THEN FOR C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2 C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND C RNSG SHOULD RETURN FOR THEM. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. RNSG RETURNS C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2 C (AFTER A RETURN WITH IV(1) = 2), RNSG RETURNS C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT. C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + P. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + 2*N + JLEN + L*(L+3)/2 + P*(2*P + 17), C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE C REQUESTED, IN WHICH CASE JLEN = N*P. C N (IN) NUMBER OF OBSERVATIONS. C NDA (IN) NUMBER OF COLUMNS IN DA AND IN. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST, C FOLLOWED BY LINEAR PARAMETERS. C Y (IN) RIGHT-HAND SIDE VECTOR. C C C *** EXTERNAL SUBROUTINES *** C REAL D7TPR, L7SVX, L7SVN, R7MDC EXTERNAL C7VFN, IVSET, D7TPR, ITSUM, L7ITV, L7SRT, L7SVX, 1 L7SVN, N2CVP, N2LRD, N2RDP, RN2G, Q7APL, Q7RAD, 2 Q7RFH, R7MDC, S7CPR, V2AXY, V7CPY, V7PRM, V7SCL, 3 V7SCP C C C7VFN... FINISHES COVARIANCE COMPUTATION. C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C ITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF. C L7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C L7SRT.... COMPUTES (PARTIAL) CHOLESKY FACTORIZATION. C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C N2CVP... PRINTS COVARIANCE MATRIX. C N2LRD... COMPUTES COVARIANCE AND REGRESSION DIAGNOSTICS. C N2RDP... PRINTS REGRESSION DIAGNOSTICS. C RN2G... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER. C Q7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY Q7RFH. C Q7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING. C Q7RAD.... QR FACT., NO PIVOTING. C R7MDC... RETURNS MACHINE-DEP. CONSTANTS. C S7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION. C V2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7PRM.... PERMUTES A VECTOR. C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C LOGICAL NOCOV INTEGER AR1, CSAVE1, D1, DR1, DR1L, DRI, DRI1, FDH0, HSAVE, I, I1, 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1, N2, 2 NML, NRAN, PP, PP1, R1, R1L, RD1, TEMP1 REAL SINGTL, T REAL MACHEP, NEGONE, SNGFAC, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AR, CNVCOD, COVMAT, COVREQ, CSAVE, CVRQSV, D, FDH, H, 1 IERS, IPIVS, IV1SAV, IVNEED, J, LMAT, MODE, NEXTIV, NEXTV, 2 NFCALL, NFCOV, NFGCAL, NGCALL, NGCOV, PERM, R, RCOND, 3 RDREQ, RDRQSV, REGD, REGD0, RESTOR, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AR/110/, CNVCOD/55/, COVMAT/26/, COVREQ/15/, CSAVE/105/, C 1 CVRQSV/106/, D/27/, FDH/74/, H/56/, IERS/108/, IPIVS/109/, C 2 IV1SAV/104/, IVNEED/3/, J/70/, LMAT/42/, MODE/35/, C 3 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFCOV/52/, NFGCAL/7/, C 4 NGCALL/30/, NGCOV/53/, PERM/58/, R/61/, RCOND/53/, RDREQ/57/, C 5 RDRQSV/107/, REGD/67/, REGD0/82/, RESTOR/9/, TOOBIG/2/, C 6 VNEED/4/ C/7 PARAMETER (AR=110, CNVCOD=55, COVMAT=26, COVREQ=15, CSAVE=105, 1 CVRQSV=106, D=27, FDH=74, H=56, IERS=108, IPIVS=109, 2 IV1SAV=104, IVNEED=3, J=70, LMAT=42, MODE=35, 3 NEXTIV=46, NEXTV=47, NFCALL=6, NFCOV=52, NFGCAL=7, 4 NGCALL=30, NGCOV=53, PERM=58, R=61, RCOND=53, RDREQ=57, 5 RDRQSV=107, REGD=67, REGD0=82, RESTOR=9, TOOBIG=2, 6 VNEED=4) C/ DATA MACHEP/-1.E+0/, NEGONE/-1.E+0/, SNGFAC/1.E+2/, ZERO/0.E+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) N1 = 1 NML = N IV1 = IV(1) IF (IV1 .LE. 2) GO TO 20 C C *** CHECK INPUT INTEGERS *** C IF (P .LE. 0) GO TO 370 IF (L .LT. 0) GO TO 370 IF (N .LE. L) GO TO 370 IF (LA .LT. N) GO TO 370 IF (IV1 .LT. 12) GO TO 20 IF (IV1 .EQ. 14) GO TO 20 IF (IV1 .EQ. 12) IV(1) = 13 C C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS *** C IF (IV(1) .GT. 16) GO TO 370 LL1O2 = L*(L+1)/2 JLEN = N*P I = L + P IF (IV(RDREQ) .GT. 0 .AND. IV(COVREQ) .NE. 0) JLEN = I*(N + I + 1) IF (IV(1) .NE. 13) GO TO 10 IV(IVNEED) = IV(IVNEED) + L IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1 CALL RN2G(V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IPIVS) = IV(NEXTIV) IV(NEXTIV) = IV(NEXTIV) + L IV(D) = IV(NEXTV) IV(REGD0) = IV(D) + P IV(AR) = IV(REGD0) + N IV(CSAVE) = IV(AR) + LL1O2 IV(J) = IV(CSAVE) + L IV(R) = IV(J) + JLEN IV(NEXTV) = IV(R) + N IV(IERS) = 0 IF (IV1 .EQ. 13) GO TO 999 C C *** SET POINTERS INTO IV AND V *** C 20 AR1 = IV(AR) D1 = IV(D) DR1 = IV(J) DR1L = DR1 + L R1 = IV(R) R1L = R1 + L RD1 = IV(REGD0) CSAVE1 = IV(CSAVE) NML = N - L IF (IV1 .LE. 2) GO TO 50 C C *** IF F.D. HESSIAN WILL BE NEEDED (FOR COVARIANCE OR REG. C *** DIAGNOSTICS), HAVE RN2G COMPUTE ONLY THE PART CORRESP. C *** TO ALF WITH C FIXED... C IF (L .LE. 0) GO TO 30 IV(CVRQSV) = IV(COVREQ) IF (IABS(IV(COVREQ)) .GE. 3) IV(COVREQ) = 0 IV(RDRQSV) = IV(RDREQ) IF (IV(RDREQ) .GT. 0) IV(RDREQ) = -1 C 30 N2 = NML CALL RN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P, 1 V(R1L), V(RD1), V, ALF) IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0) 1 CALL V7CPY(L, C, V(CSAVE1)) IV1 = IV(1) IF (IV1-2) 40, 150, 230 C C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED *** C 40 IV(IV1SAV) = IV(1) IV(1) = IABS(IV1) IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL V7CPY(L, V(CSAVE1), C) GO TO 999 C C *** COMPUTE NEW RESIDUAL OR GRADIENT *** C 50 IV(1) = IV(IV1SAV) MD = IV(MODE) IF (MD .LE. 0) GO TO 60 NML = N DR1L = DR1 R1L = R1 60 IF (IV(TOOBIG) .NE. 0) GO TO 30 IF (IABS(IV1) .EQ. 2) GO TO 170 C C *** COMPUTE NEW RESIDUAL *** C IF (L1 .LE. L) CALL V7CPY(N, V(R1), Y) IF (L1 .GT. L) CALL V2AXY(N, V(R1), NEGONE, A(1,L1), Y) IF (MD .GT. 0) GO TO 120 IER = 0 IF (L .LE. 0) GO TO 110 LL1O2 = L * (L + 1) / 2 IPIV1 = IV(IPIVS) CALL Q7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C) C C *** DETERMINE NUMERICAL RANK OF A *** C IF (MACHEP .LE. ZERO) MACHEP = R7MDC(3) SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP K = L IF (IER .NE. 0) K = IER - 1 70 IF (K .LE. 0) GO TO 90 T = L7SVX(K, V(AR1), C, C) IF (T .GT. ZERO) T = L7SVN(K, V(AR1), C, C) / T IF (T .GT. SINGTL) GO TO 80 K = K - 1 GO TO 70 C C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK, C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1. C 80 IF (K .GE. L) GO TO 100 90 IER = K + 1 CALL V7SCP(L-K, C(K+1), ZERO) 100 IV(IERS) = IER IF (K .LE. 0) GO TO 110 C C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS... C CALL Q7APL(LA, N, K, A, V(R1), IER) C C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT C *** THE LAST ITERATION. C CALL L7ITV(K, C, V(AR1), V(R1)) CALL V7PRM(L, IV(IPIV1), C) C 110 IF(IV(1) .LT. 2) GO TO 220 GO TO 999 C C C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN *** C 120 IF (L .LE. 0) GO TO 140 DO 130 I = 1, L 130 CALL V2AXY(N, V(R1), -C(I), A(1,I), V(R1)) 140 IF (IV(1) .GT. 0) GO TO 30 IV(1) = 2 GO TO 160 C C *** NEW GRADIENT (JACOBIAN) NEEDED *** C 150 IV(IV1SAV) = IV1 IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1 160 CALL V7SCP(N*P, V(DR1), ZERO) GO TO 999 C C *** COMPUTE NEW JACOBIAN *** C 170 NOCOV = MD .LE. P .OR. IABS(IV(COVREQ)) .GE. 3 FDH0 = DR1 + N*(P+L) IF (NDA .LE. 0) GO TO 370 DO 180 I = 1, NDA I1 = IN(1,I) - 1 IF (I1 .LT. 0) GO TO 180 J1 = IN(2,I) K = DR1 + I1*N T = NEGONE IF (J1 .LE. L) T = -C(J1) CALL V2AXY(N, V(K), T, DA(1,I), V(K)) IF (NOCOV) GO TO 180 IF (J1 .GT. L) GO TO 180 C *** ADD IN (L,P) PORTION OF SECOND-ORDER PART OF HESSIAN C *** FOR COVARIANCE OR REG. DIAG. COMPUTATIONS... J1 = J1 + P K = FDH0 + J1*(J1-1)/2 + I1 V(K) = V(K) - D7TPR(N, V(R1), DA(1,I)) 180 CONTINUE IF (IV1 .EQ. 2) GO TO 190 IV(1) = IV1 GO TO 999 190 IF (L .LE. 0) GO TO 30 IF (MD .GT. P) GO TO 240 IF (MD .GT. 0) GO TO 30 K = DR1 IER = IV(IERS) NRAN = L IF (IER .GT. 0) NRAN = IER - 1 IF (NRAN .LE. 0) GO TO 210 DO 200 I = 1, P CALL Q7APL(LA, N, NRAN, A, V(K), IER) K = K + N 200 CONTINUE 210 CALL V7CPY(L, V(CSAVE1), C) 220 IF (IER .EQ. 0) GO TO 30 C C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR... C NRAN = IER - 1 DR1L = DR1 + NRAN NML = N - NRAN R1L = R1 + NRAN GO TO 30 C C *** CONVERGENCE OR LIMIT REACHED *** C 230 IF (L .LE. 0) GO TO 350 IV(COVREQ) = IV(CVRQSV) IV(RDREQ) = IV(RDRQSV) IF (IV(1) .GT. 6) GO TO 360 IF (MOD(IV(RDREQ),4) .EQ. 0) GO TO 360 IF (IV(FDH) .LE. 0 .AND. IABS(IV(COVREQ)) .LT. 3) GO TO 360 IF (IV(REGD) .GT. 0) GO TO 360 IF (IV(COVMAT) .GT. 0) GO TO 360 C C *** PREPARE TO FINISH COMPUTING COVARIANCE MATRIX AND REG. DIAG. *** C PP = L + P I = 0 IF (MOD(IV(RDREQ),4) .GE. 2) I = 1 IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .EQ. 1) I = I+2 IV(MODE) = PP + I I = DR1 + N*PP K = P * (P + 1) / 2 I1 = IV(LMAT) CALL V7CPY(K, V(I), V(I1)) I = I + K CALL V7SCP(PP*(PP+1)/2 - K, V(I), ZERO) IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(CNVCOD) = IV(1) IV(IV1SAV) = -1 IV(1) = 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 GO TO 999 C C *** FINISH COVARIANCE COMPUTATION *** C 240 I = DR1 + N*P DO 250 I1 = 1, L CALL V7SCL(N, V(I), NEGONE, A(1,I1)) I = I + N 250 CONTINUE PP = L + P HSAVE = IV(H) K = DR1 + N*PP LH = PP * (PP + 1) / 2 IF (IABS(IV(COVREQ)) .LT. 3) GO TO 270 I = IV(MODE) - 4 IF (I .GE. PP) GO TO 260 CALL V7SCP(LH, V(K), ZERO) CALL Q7RAD(N, N, PP, V, .FALSE., V(K), V(DR1), V) IV(MODE) = I + 8 IV(1) = 2 IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 GO TO 160 C 260 IV(MODE) = I GO TO 300 C 270 PP1 = P + 1 DRI = DR1 + N*P LI = K + P*PP1/2 DO 290 I = PP1, PP DRI1 = DR1 DO 280 I1 = 1, I V(LI) = V(LI) + D7TPR(N, V(DRI), V(DRI1)) LI = LI + 1 DRI1 = DRI1 + N 280 CONTINUE DRI = DRI + N 290 CONTINUE CALL L7SRT(PP1, PP, V(K), V(K), I) IF (I .NE. 0) GO TO 310 300 TEMP1 = K + LH T = L7SVN(PP, V(K), V(TEMP1), V(TEMP1)) IF (T .LE. ZERO) GO TO 310 T = T / L7SVX(PP, V(K), V(TEMP1), V(TEMP1)) V(RCOND) = T IF (T .GT. R7MDC(4)) GO TO 320 310 IV(REGD) = -1 IV(COVMAT) = -1 IV(FDH) = -1 GO TO 340 320 IV(H) = TEMP1 IV(FDH) = IABS(HSAVE) IF (IV(MODE) - PP .LT. 2) GO TO 330 I = IV(H) CALL V7SCP(LH, V(I), ZERO) 330 CALL N2LRD(V(DR1), IV, V(K), LH, LIV, LV, N, N, PP, V(R1), 1 V(RD1), V) 340 CALL C7VFN(IV, V(K), LH, LIV, LV, N, PP, V) IV(H) = HSAVE C 350 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1 360 IF (IV(1) .LE. 11) CALL S7CPR(C, IV, L, LIV) IF (IV(1) .GT. 6) GO TO 999 CALL N2CVP(IV, LIV, LV, P+L, V) CALL N2RDP(IV, LIV, LV, N, V(RD1), V) GO TO 999 C 370 IV(1) = 66 CALL ITSUM(V, V, IV, LIV, LV, P, V, ALF) C 999 RETURN C C *** LAST CARD OF RNSG FOLLOWS *** END SUBROUTINE RNSGB(A, ALF, B, C, DA, IN, IV, L, L1, LA, LIV, LV, 1 N, NDA, P, V, Y) C C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES, C *** WITH SIMPLE BOUNDS ON THE NONLINEAR VARIABLES. C C *** PARAMETER DECLARATIONS *** C INTEGER L, L1, LA, LIV, LV, N, NDA, P INTEGER IN(2,NDA), IV(LIV) C DIMENSION UIPARM(*) REAL A(LA,L1), ALF(P), B(2,P), C(L), DA(LA,NDA), 1 V(LV), Y(N) C C *** PURPOSE *** C C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE C T(1)...T(N), RNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION C C L C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T) C J=1 J J L+1 C C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P) C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES C NONLINEAR PARAMETERS ALF WHICH MINIMIZE C C 2 N 2 C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) , C I=1 I I C C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS C B(1,I) .LE. ALF(I) .LE. B(2,I), I = 1(1)P. C C THE (L+1)ST TERM IS OPTIONAL. C C C *** PARAMETERS *** C C A (IN) MATRIX PHI(ALF,T) OF THE MODEL. C ALF (I/O) NONLINEAR PARAMETERS. C INPUT = INITIAL GUESS, C OUTPUT = BEST ESTIMATE FOUND. C C (OUT) LINEAR PARAMETERS (ESTIMATED). C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS C OF ALF, AS SPECIFIED BY THE IN ARRAY... C IN (IN) WHEN RNSGB IS CALLED WITH IV(1) = 2 OR -2, THEN FOR C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2 C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND C RNSGB SHOULD RETURN FOR THEM. C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. RNSGB RETURNS C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2 C (AFTER A RETURN WITH IV(1) = 2), RNSGB RETURNS C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA. C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED. C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT. C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N. C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + 4*P. C LV (IN) LENGTH OF V. MUST BE AT LEAST C 105 + 2*N + L*(L+3)/2 + P*(2*P + 21 + N). C N (IN) NUMBER OF OBSERVATIONS. C NDA (IN) NUMBER OF COLUMNS IN DA AND IN. C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED. C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR. C Y (IN) RIGHT-HAND SIDE VECTOR. C C C *** EXTERNAL SUBROUTINES *** C REAL L7SVX, L7SVN, R7MDC EXTERNAL IVSET, ITSUM, L7ITV, L7SVX, L7SVN, RN2GB, Q7APL, 1 Q7RFH, R7MDC, S7CPR, V2AXY, V7CPY, V7PRM, V7SCP C C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES. C ITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF. C L7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C RN2GB... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER. C Q7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY Q7RFH. C Q7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING. C R7MDC... RETURNS MACHINE-DEP. CONSTANTS. C S7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION. C V2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7PRM.... PERMUTES VECTOR. C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER AR1, CSAVE1, D1, DR1, DR1L, I, I1, 1 IPIV1, IER, IV1, J1, JLEN, K, LL1O2, MD, N1, N2, 2 NML, NRAN, R1, R1L, RD1 REAL SINGTL, T REAL MACHEP, NEGONE, SNGFAC, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AR, CSAVE, D, IERS, IPIVS, IV1SAV, 2 IVNEED, J, MODE, NEXTIV, NEXTV, 2 NFCALL, NFGCAL, PERM, R, 3 REGD, REGD0, RESTOR, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA AR/110/, CSAVE/105/, D/27/, IERS/108/, IPIVS/109/, C 1 IV1SAV/104/, IVNEED/3/, J/70/, MODE/35/, NEXTIV/46/, C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, PERM/58/, R/61/, REGD/67/, C 3 REGD0/82/, RESTOR/9/, TOOBIG/2/, VNEED/4/ C/7 PARAMETER (AR=110, CSAVE=105, D=27, IERS=108, IPIVS=109, 1 IV1SAV=104, IVNEED=3, J=70, MODE=35, NEXTIV=46, 2 NEXTV=47, NFCALL=6, NFGCAL=7, PERM=58, R=61, REGD=67, 3 REGD0=82, RESTOR=9, TOOBIG=2, VNEED=4) C/ DATA MACHEP/-1.E+0/, NEGONE/-1.E+0/, SNGFAC/1.E+2/, ZERO/0.E+0/ C C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++ C C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) N1 = 1 NML = N IV1 = IV(1) IF (IV1 .LE. 2) GO TO 20 C C *** CHECK INPUT INTEGERS *** C IF (P .LE. 0) GO TO 240 IF (L .LT. 0) GO TO 240 IF (N .LE. L) GO TO 240 IF (LA .LT. N) GO TO 240 IF (IV1 .LT. 12) GO TO 20 IF (IV1 .EQ. 14) GO TO 20 IF (IV1 .EQ. 12) IV(1) = 13 C C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS *** C IF (IV(1) .GT. 16) GO TO 240 LL1O2 = L*(L+1)/2 JLEN = N*P I = L + P IF (IV(1) .NE. 13) GO TO 10 IV(IVNEED) = IV(IVNEED) + L IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1 CALL RN2GB(B, V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(IPIVS) = IV(NEXTIV) IV(NEXTIV) = IV(NEXTIV) + L IV(D) = IV(NEXTV) IV(REGD0) = IV(D) + P IV(AR) = IV(REGD0) + N IV(CSAVE) = IV(AR) + LL1O2 IV(J) = IV(CSAVE) + L IV(R) = IV(J) + JLEN IV(NEXTV) = IV(R) + N IV(IERS) = 0 IF (IV1 .EQ. 13) GO TO 999 C C *** SET POINTERS INTO IV AND V *** C 20 AR1 = IV(AR) D1 = IV(D) DR1 = IV(J) DR1L = DR1 + L R1 = IV(R) R1L = R1 + L RD1 = IV(REGD0) CSAVE1 = IV(CSAVE) NML = N - L IF (IV1 .LE. 2) GO TO 50 C 30 N2 = NML CALL RN2GB(B, V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P, 1 V(R1L), V(RD1), V, ALF) IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0) 1 CALL V7CPY(L, C, V(CSAVE1)) IV1 = IV(1) IF (IV1-2) 40, 150, 230 C C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED *** C 40 IV(IV1SAV) = IV(1) IV(1) = IABS(IV1) IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL V7CPY(L, V(CSAVE1), C) GO TO 999 C C *** COMPUTE NEW RESIDUAL OR GRADIENT *** C 50 IV(1) = IV(IV1SAV) MD = IV(MODE) IF (MD .LE. 0) GO TO 60 NML = N DR1L = DR1 R1L = R1 60 IF (IV(TOOBIG) .NE. 0) GO TO 30 IF (IABS(IV1) .EQ. 2) GO TO 170 C C *** COMPUTE NEW RESIDUAL *** C IF (L1 .LE. L) CALL V7CPY(N, V(R1), Y) IF (L1 .GT. L) CALL V2AXY(N, V(R1), NEGONE, A(1,L1), Y) IF (MD .GT. 0) GO TO 120 IER = 0 IF (L .LE. 0) GO TO 110 LL1O2 = L * (L + 1) / 2 IPIV1 = IV(IPIVS) CALL Q7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C) C C *** DETERMINE NUMERICAL RANK OF A *** C IF (MACHEP .LE. ZERO) MACHEP = R7MDC(3) SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP K = L IF (IER .NE. 0) K = IER - 1 70 IF (K .LE. 0) GO TO 90 T = L7SVX(K, V(AR1), C, C) IF (T .GT. ZERO) T = L7SVN(K, V(AR1), C, C) / T IF (T .GT. SINGTL) GO TO 80 K = K - 1 GO TO 70 C C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK, C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1. C 80 IF (K .GE. L) GO TO 100 90 IER = K + 1 CALL V7SCP(L-K, C(K+1), ZERO) 100 IV(IERS) = IER IF (K .LE. 0) GO TO 110 C C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS... C CALL Q7APL(LA, N, K, A, V(R1), IER) C C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT C *** THE LAST ITERATION. C CALL L7ITV(K, C, V(AR1), V(R1)) CALL V7PRM(L, IV(IPIV1), C) C 110 IF(IV(1) .LT. 2) GO TO 220 GO TO 999 C C C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN *** C 120 IF (L .LE. 0) GO TO 140 DO 130 I = 1, L 130 CALL V2AXY(N, V(R1), -C(I), A(1,I), V(R1)) 140 IF (IV(1) .GT. 0) GO TO 30 IV(1) = 2 GO TO 160 C C *** NEW GRADIENT (JACOBIAN) NEEDED *** C 150 IV(IV1SAV) = IV1 IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1 160 CALL V7SCP(N*P, V(DR1), ZERO) GO TO 999 C C *** COMPUTE NEW JACOBIAN *** C 170 IF (NDA .LE. 0) GO TO 240 DO 180 I = 1, NDA I1 = IN(1,I) - 1 IF (I1 .LT. 0) GO TO 180 J1 = IN(2,I) K = DR1 + I1*N T = NEGONE IF (J1 .LE. L) T = -C(J1) CALL V2AXY(N, V(K), T, DA(1,I), V(K)) 180 CONTINUE IF (IV1 .EQ. 2) GO TO 190 IV(1) = IV1 GO TO 999 190 IF (L .LE. 0) GO TO 30 IF (MD .GT. 0) GO TO 30 K = DR1 IER = IV(IERS) NRAN = L IF (IER .GT. 0) NRAN = IER - 1 IF (NRAN .LE. 0) GO TO 210 DO 200 I = 1, P CALL Q7APL(LA, N, NRAN, A, V(K), IER) K = K + N 200 CONTINUE 210 CALL V7CPY(L, V(CSAVE1), C) 220 IF (IER .EQ. 0) GO TO 30 C C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR... C NRAN = IER - 1 DR1L = DR1 + NRAN NML = N - NRAN R1L = R1 + NRAN GO TO 30 C C *** CONVERGENCE OR LIMIT REACHED *** C 230 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1 IF (IV(1) .LE. 11) CALL S7CPR(C, IV, L, LIV) GO TO 999 C 240 IV(1) = 66 CALL ITSUM(V, V, IV, LIV, LV, P, V, ALF) C 999 RETURN C C *** LAST CARD OF RNSGB FOLLOWS *** END SUBROUTINE S1MACH C C S1MACH TESTS THE CONSISTENCY OF THE MACHINE CONSTANTS IN C I1MACH, R1MACH AND D1MACH. C INTEGER IMACH(16),I1MACH INTEGER STDOUT INTEGER DIGINT, DIGSP, DIGDP REAL RMACH(5),R1MACH REAL S2MACH, XR, YR REAL SBASE, SBASEM REAL ALOG10, SQRT DOUBLE PRECISION DLOG10, DSQRT DOUBLE PRECISION DMACH(5),D1MACH DOUBLE PRECISION S3MACH, XD, YD DOUBLE PRECISION DBASE, DBASEM C C/6S C INTEGER IFMT(12) C INTEGER EFMT(15) C INTEGER DFMT(15) C INTEGER CCPLUS C/7S CHARACTER*1 IFMT1(12), EFMT1(15), DFMT1(15), CCPLUS CHARACTER*12 IFMT CHARACTER*15 EFMT, DFMT EQUIVALENCE (IFMT1(1),IFMT), (EFMT1(1),EFMT), (DFMT1(1),DFMT) C/ INTEGER DWIDTH, WWIDTH, EWIDTH INTEGER DEMAX, DEMIN C EQUIVALENCE ( STDOUT, IMACH(2) ) EQUIVALENCE ( DIGINT, IMACH(8) ) EQUIVALENCE ( DIGSP, IMACH(11) ) EQUIVALENCE ( DIGDP, IMACH(14) ) C C/6S C DATA CCPLUS / 1H+ / C/7S DATA CCPLUS / '+' / C/ C C/6S C DATA IFMT(1 ) / 1H( / C DATA IFMT(2 ) / 1HA / C DATA IFMT(3 ) / 1H1 / C DATA IFMT(4 ) / 1H, / C DATA IFMT(5 ) / 1H5 / C DATA IFMT(6 ) / 1H1 / C DATA IFMT(7 ) / 1HX / C DATA IFMT(8 ) / 1H, / C DATA IFMT(9 ) / 1HI / C DATA IFMT(10) / 1H / C DATA IFMT(11) / 1H / C DATA IFMT(12) / 1H) / C/7S DATA IFMT1(1 ) / '(' / DATA IFMT1(2 ) / 'A' / DATA IFMT1(3 ) / '1' / DATA IFMT1(4 ) / ',' / DATA IFMT1(5 ) / '5' / DATA IFMT1(6 ) / '1' / DATA IFMT1(7 ) / 'X' / DATA IFMT1(8 ) / ',' / DATA IFMT1(9 ) / 'I' / DATA IFMT1(10) / ' ' / DATA IFMT1(11) / ' ' / DATA IFMT1(12) / ')' / C/ C C/6S C DATA EFMT( 1) / 1H( /, DFMT( 1) / 1H( / C DATA EFMT( 2) / 1HA /, DFMT( 2) / 1HA / C DATA EFMT( 3) / 1H1 /, DFMT( 3) / 1H1 / C DATA EFMT( 4) / 1H, /, DFMT( 4) / 1H, / C DATA EFMT( 5) / 1H3 /, DFMT( 5) / 1H3 / C DATA EFMT( 6) / 1H2 /, DFMT( 6) / 1H2 / C DATA EFMT( 7) / 1HX /, DFMT( 7) / 1HX / C DATA EFMT( 8) / 1H, /, DFMT( 8) / 1H, / C DATA EFMT( 9) / 1HE /, DFMT( 9) / 1HD / C DATA EFMT(10) / 1H /, DFMT(10) / 1H / C DATA EFMT(11) / 1H /, DFMT(11) / 1H / C DATA EFMT(12) / 1H. /, DFMT(12) / 1H. / C DATA EFMT(13) / 1H /, DFMT(13) / 1H / C DATA EFMT(14) / 1H /, DFMT(14) / 1H / C DATA EFMT(15) / 1H) /, DFMT(15) / 1H) / C/7S DATA EFMT1( 1) / '(' /, DFMT1( 1) / '(' / DATA EFMT1( 2) / 'A' /, DFMT1( 2) / 'A' / DATA EFMT1( 3) / '1' /, DFMT1( 3) / '1' / DATA EFMT1( 4) / ',' /, DFMT1( 4) / ',' / DATA EFMT1( 5) / '3' /, DFMT1( 5) / '3' / DATA EFMT1( 6) / '2' /, DFMT1( 6) / '2' / DATA EFMT1( 7) / 'X' /, DFMT1( 7) / 'X' / DATA EFMT1( 8) / ',' /, DFMT1( 8) / ',' / DATA EFMT1( 9) / 'E' /, DFMT1( 9) / 'D' / DATA EFMT1(10) / ' ' /, DFMT1(10) / ' ' / DATA EFMT1(11) / ' ' /, DFMT1(11) / ' ' / DATA EFMT1(12) / '.' /, DFMT1(12) / '.' / DATA EFMT1(13) / ' ' /, DFMT1(13) / ' ' / DATA EFMT1(14) / ' ' /, DFMT1(14) / ' ' / DATA EFMT1(15) / ')' /, DFMT1(15) / ')' / C/ C C FETCH ALL CONSTANTS INTO LOCAL ARRAYS C DO 10 I = 1,16 IMACH(I) = I1MACH(I) 10 CONTINUE C DO 20 I = 1,5 RMACH(I) = R1MACH(I) DMACH(I) = D1MACH(I) 20 CONTINUE C C COMPUTE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING C OUT THE LARGEST INTEGER ALLOWING FOR ONE SPACE AND A SIGN C AND PLUG THE FIELD WIDTH IN THE FORMAT. C WWIDTH = ICEIL( ALOG10(FLOAT(IMACH(7)))*FLOAT(IMACH(8)) ) + 2 C/6S C CALL S88FMT( 2, WWIDTH, IFMT(10) ) C WRITE( STDOUT, 900 ) ( IFMT(I), I = 9, 11 ) C/7S CALL S88FMT( 2, WWIDTH, IFMT1(10) ) WRITE( STDOUT, 900 ) ( IFMT1(I), I = 9, 11 ) C/ 900 FORMAT(//37H FORMAT CONVERSION FOR INTEGERS IS - ,3A1 1 / 25H INTEGER CONSTANTS FOLLOW///) C C NOW WRITE OUT THE INTEGER CONSTANTS C WRITE( STDOUT, 1001 ) 1001 FORMAT(24H THE STANDARD INPUT UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(1) C WRITE( STDOUT, 1002 ) 1002 FORMAT(25H THE STANDARD OUTPUT UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(2) C WRITE( STDOUT, 1003 ) 1003 FORMAT(24H THE STANDARD PUNCH UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(3) C WRITE( STDOUT, 1004 ) 1004 FORMAT(32H THE STANDARD ERROR MESSAGE UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(4) C WRITE( STDOUT, 1005 ) 1005 FORMAT(28H THE NUMBER OF BITS PER WORD) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(5) C WRITE( STDOUT, 1006 ) 1006 FORMAT(34H THE NUMBER OF CHARACTERS PER WORD) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(6) C WRITE( STDOUT, 1007 ) 1007 FORMAT(34H A, THE BASE OF AN S-DIGIT INTEGER) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7) C WRITE( STDOUT, 1008 ) 1008 FORMAT(31H S, THE NUMBER OF BASE-A DIGITS) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8) C WRITE( STDOUT, 1009 ) 1009 FORMAT(32H A**S - 1, THE LARGEST MAGNITUDE) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9) C WRITE( STDOUT, 1010 ) 1010 FORMAT(47H B, THE BASE OF A T-DIGIT FLOATING-POINT NUMBER) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(10) C WRITE( STDOUT, 1011 ) 1011 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN SINGLE-PRECISION) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11) C WRITE( STDOUT, 1012 ) 1012 FORMAT(45H EMIN, THE SMALLEST SINGLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12) C WRITE( STDOUT, 1013 ) 1013 FORMAT(44H EMAX, THE LARGEST SINGLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13) C WRITE( STDOUT, 1014 ) 1014 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN DOUBLE-PRECISION) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14) C WRITE( STDOUT, 1015 ) 1015 FORMAT(45H EMIN, THE SMALLEST DOUBLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15) C WRITE( STDOUT, 1016 ) 1016 FORMAT(44H EMAX, THE LARGEST DOUBLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16) C C COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING C OUT A SINGLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND C A SIGN AND PLUG THE FIELDS IN THE FORMAT. C DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(11)) ) C/6S C CALL S88FMT( 2, DWIDTH, EFMT(13) ) C/7S CALL S88FMT( 2, DWIDTH, EFMT1(13) ) C/ DEMIN = IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(12)-1) ) + 1 DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(13)) ) EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1 WWIDTH = DWIDTH + EWIDTH + 6 C/6S C CALL S88FMT( 2, WWIDTH, EFMT(10) ) C WRITE( STDOUT, 1900 ) ( EFMT(I), I = 9, 14 ) C/7S CALL S88FMT( 2, WWIDTH, EFMT1(10) ) WRITE( STDOUT, 1900 ) ( EFMT1(I), I = 9, 14 ) C/ 1900 FORMAT(//45H FORMAT CONVERSION FOR SINGLE-PRECISION IS - ,6A1 1 / 34H SINGLE-PRECISION CONSTANTS FOLLOW///) C C NOW WRITE OUT THE SINGLE-PRECISION CONSTANTS C WRITE( STDOUT, 2001 ) 2001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1) C WRITE( STDOUT, 2002 ) 2002 FORMAT(22H THE LARGEST MAGNITUDE) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2) C WRITE( STDOUT, 2003 ) 2003 FORMAT(30H THE SMALLEST RELATIVE SPACING) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3) C WRITE( STDOUT, 2004 ) 2004 FORMAT(29H THE LARGEST RELATIVE SPACING) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4) C WRITE( STDOUT, 2005 ) 2005 FORMAT(18H LOG10 OF THE BASE) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5) C/6S C CALL S88FMT( 2, WWIDTH+1, EFMT(10) ) C CALL S88FMT( 2, DWIDTH+1, EFMT(13) ) C/7S CALL S88FMT( 2, WWIDTH+1, EFMT1(10) ) CALL S88FMT( 2, DWIDTH+1, EFMT1(13) ) C/ C COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING C OUT A DOUBLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND C A SIGN AND PLUG THE FIELDS IN THE FORMAT. C DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(14)) ) C/6S C CALL S88FMT( 2, DWIDTH, DFMT(13) ) C/7S CALL S88FMT( 2, DWIDTH, DFMT1(13) ) C/ DEMIN = IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(15)-1) ) + 1 DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(16)) ) EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1 WWIDTH = DWIDTH + EWIDTH + 6 C/6S C CALL S88FMT( 2, WWIDTH, DFMT(10) ) C WRITE( STDOUT, 2900 ) ( DFMT(I), I = 9, 14 ) C/7S CALL S88FMT( 2, WWIDTH, DFMT1(10) ) WRITE( STDOUT, 2900 ) ( DFMT1(I), I = 9, 14 ) C/ 2900 FORMAT(//45H FORMAT CONVERSION FOR DOUBLE-PRECISION IS - ,6A1 1 / 34H DOUBLE-PRECISION CONSTANTS FOLLOW///) C C NOW WRITE OUT THE DOUBLE-PRECISION CONSTANTS C WRITE( STDOUT, 3001 ) 3001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1) C WRITE( STDOUT, 3002 ) 3002 FORMAT(22H THE LARGEST MAGNITUDE) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2) C WRITE( STDOUT, 3003 ) 3003 FORMAT(30H THE SMALLEST RELATIVE SPACING) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3) C WRITE( STDOUT, 3004 ) 3004 FORMAT(29H THE LARGEST RELATIVE SPACING) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4) C WRITE( STDOUT, 3005 ) 3005 FORMAT(18H LOG10 OF THE BASE) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5) C/6S C CALL S88FMT( 2, WWIDTH+1, DFMT(10) ) C CALL S88FMT( 2, DWIDTH+1, DFMT(13) ) C/7S CALL S88FMT( 2, WWIDTH+1, DFMT1(10) ) CALL S88FMT( 2, DWIDTH+1, DFMT1(13) ) C/ C NOW CHECK CONSISTENCY OF INTEGER CONSTANTS C/6S C CALL S88FMT( 2, 14, IFMT(5) ) C/7S CALL S88FMT( 2, 14, IFMT1(5) ) C/ IF( IMACH(11) .LE. IMACH(14) ) GOTO 4009 WRITE( STDOUT, 4001 ) 4001 FORMAT(30H0I1MACH(11) EXCEEDS I1MACH(14) ) WRITE( STDOUT, 4002 ) 4002 FORMAT(13H I1MACH(11) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11) WRITE( STDOUT, 4003 ) 4003 FORMAT(13H I1MACH(14) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14) 4009 CONTINUE C IF( IMACH(13) .LE. IMACH(16) ) GOTO 4019 WRITE( STDOUT, 4011 ) 4011 FORMAT(40H0WARNING - I1MACH(13) EXCEEDS I1MACH(16) ) WRITE( STDOUT, 4012 ) 4012 FORMAT(13H I1MACH(13) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13) WRITE( STDOUT, 4013 ) 4013 FORMAT(13H I1MACH(16) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16) 4019 CONTINUE C IF( IMACH(16)-IMACH(15) .GE. IMACH(13)-IMACH(12) ) GOTO 4029 WRITE( STDOUT, 4021 ) 4021 FORMAT(34H0WARNING - I1MACH(13) - I1MACH(12) ) WRITE( STDOUT, 4022 ) 4022 FORMAT(32H EXCEEDS I1MACH(16) - I1MACH(15) ) WRITE( STDOUT, 4023 ) 4023 FORMAT(13H I1MACH(12) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12) WRITE( STDOUT, 4024 ) 4024 FORMAT(13H I1MACH(13) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13) WRITE( STDOUT, 4025 ) 4025 FORMAT(13H I1MACH(15) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15) WRITE( STDOUT, 4026 ) 4026 FORMAT(13H I1MACH(16) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16) 4029 CONTINUE C N = 0 IBASEM = IMACH(7) - 1 DO 4030 I = 1, DIGINT N = N*IMACH(7) + IBASEM 4030 CONTINUE C IF( IMACH(9) .EQ. N) GOTO 4039 WRITE( STDOUT, 4031 ) 4031 FORMAT(39H1IMACH(9) IS NOT IMACH(7)**IMACH(8) - 1 ) WRITE( STDOUT, 4032 ) 4032 FORMAT(12H I1MACH(7) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7) WRITE( STDOUT, 4034 ) 4034 FORMAT(12H I1MACH(8) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8) WRITE( STDOUT, 4035 ) 4035 FORMAT(12H I1MACH(9) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9) 4039 CONTINUE C C NOW CHECK CONSISTENCY OF SINGLE-PRECISION CONSTANTS C/6S C CALL S88FMT( 2, 19, EFMT(5) ) C/7S CALL S88FMT( 2, 19, EFMT1(5) ) C/ XR = S2MACH( 1.0, IMACH(10), IMACH(12)-1 ) IF( XR .EQ. RMACH(1) ) GOTO 5009 WRITE( STDOUT, 5001 ) 5001 FORMAT(47H0R1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5002 ) 5002 FORMAT(12H R1MACH(1) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1) WRITE( STDOUT, 5003 ) 5003 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5004 ) 5004 FORMAT(14H DIFFERENCE = ) XR = RMACH(1) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5009 CONTINUE C XR = 0.0 SBASE = FLOAT( IMACH(10) ) SBASEM = FLOAT( IMACH(10)-1 ) DO 5010 I = 1, DIGSP XR = (XR + SBASEM)/SBASE 5010 CONTINUE C XR = S2MACH( XR, IMACH(10), IMACH(13) ) IF( XR .EQ. RMACH(2) ) GOTO 5019 WRITE( STDOUT, 5011 ) 5011 FORMAT(47H0R1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5012 ) 5012 FORMAT(12H R1MACH(2) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2) WRITE( STDOUT, 5013 ) 5013 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5014 ) 5014 FORMAT(14H DIFFERENCE = ) XR = RMACH(2) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5019 CONTINUE C XR = S2MACH( 1.0, IMACH(10), -IMACH(11) ) IF( XR .EQ. RMACH(3) ) GOTO 5029 WRITE( STDOUT, 5021 ) 5021 FORMAT(47H0R1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5022 ) 5022 FORMAT(12H R1MACH(3) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3) WRITE( STDOUT, 5023 ) 5023 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5024 ) 5024 FORMAT(14H DIFFERENCE = ) XR = RMACH(3) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5029 CONTINUE C XR = S2MACH( 1.0, IMACH(10), 1-IMACH(11) ) IF( XR .EQ. RMACH(4) ) GOTO 5039 WRITE( STDOUT, 5031 ) 5031 FORMAT(47H0R1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5032 ) 5032 FORMAT(12H R1MACH(4) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4) WRITE( STDOUT, 5033 ) 5033 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5034 ) 5034 FORMAT(14H DIFFERENCE = ) XR = RMACH(4) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5039 CONTINUE C XR = ALOG10( FLOAT(IMACH(10)) ) IF( XR .EQ. RMACH(5) ) GOTO 5049 WRITE( STDOUT, 5041 ) 5041 FORMAT(47H0R1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5042 ) 5042 FORMAT(12H R1MACH(5) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5) WRITE( STDOUT, 5043 ) 5043 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5044 ) 5044 FORMAT(14H DIFFERENCE = ) XR = RMACH(5) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5049 CONTINUE C C NOW CHECK CONSISTENCY OF DOUBLE-PRECISION CONSTANTS C/6S C CALL S88FMT( 2, 19, DFMT(5) ) C/7S CALL S88FMT( 2, 19, DFMT1(5) ) C/ XD = S3MACH( 1.0D0, IMACH(10), IMACH(15)-1 ) IF( XD .EQ. DMACH(1) ) GOTO 6009 WRITE( STDOUT, 6001 ) 6001 FORMAT(47H0D1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6002 ) 6002 FORMAT(12H D1MACH(1) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1) WRITE( STDOUT, 6003 ) 6003 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6004 ) 6004 FORMAT(14H DIFFERENCE = ) XD = DMACH(1) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6009 CONTINUE C XD = 0.0D0 DBASE = DBLE ( FLOAT( IMACH(10) ) ) DBASEM = DBLE ( FLOAT( IMACH(10)-1 ) ) DO 6010 I = 1, DIGDP XD = (XD + DBASEM)/DBASE 6010 CONTINUE C XD = S3MACH( XD, IMACH(10), IMACH(16) ) IF( XD .EQ. DMACH(2) ) GOTO 6019 WRITE( STDOUT, 6011 ) 6011 FORMAT(47H0D1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6012 ) 6012 FORMAT(12H D1MACH(2) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2) WRITE( STDOUT, 6013 ) 6013 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6014 ) 6014 FORMAT(14H DIFFERENCE = ) XD = DMACH(2) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6019 CONTINUE C XD = S3MACH( 1.0D0, IMACH(10), -IMACH(14) ) IF( XD .EQ. DMACH(3) ) GOTO 6029 WRITE( STDOUT, 6021 ) 6021 FORMAT(47H0D1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6022 ) 6022 FORMAT(12H D1MACH(3) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3) WRITE( STDOUT, 6023 ) 6023 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6024 ) 6024 FORMAT(14H DIFFERENCE = ) XD = DMACH(3) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6029 CONTINUE C XD = S3MACH( 1.0D0, IMACH(10), 1-IMACH(14) ) IF( XD .EQ. DMACH(4) ) GOTO 6039 WRITE( STDOUT, 6031 ) 6031 FORMAT(47H0D1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6032 ) 6032 FORMAT(12H D1MACH(4) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4) WRITE( STDOUT, 6033 ) 6033 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6034 ) 6034 FORMAT(14H DIFFERENCE = ) XD = DMACH(4) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6039 CONTINUE C XD = DLOG10( DBLE(FLOAT(IMACH(10))) ) IF( XD .EQ. DMACH(5) ) GOTO 6049 WRITE( STDOUT, 6041 ) 6041 FORMAT(47H0D1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6042 ) 6042 FORMAT(12H D1MACH(5) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5) WRITE( STDOUT, 6043 ) 6043 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6044 ) 6044 FORMAT(14H DIFFERENCE = ) XD = DMACH(5) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6049 CONTINUE C C NOW SEE IF SINGLE-PRECISION IS CLOSED UNDER NEGATION C XR = -RMACH(1) XR = -XR IF( XR .EQ. RMACH(1) ) GOTO 7009 WRITE( STDOUT, 7001 ) 7001 FORMAT(29H0-(-R1MACH(1)) .NE. R1MACH(1)) WRITE( STDOUT, 7002 ) 7002 FORMAT(16H R1MACH(1) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1) WRITE( STDOUT, 7003 ) 7003 FORMAT(16H -(-R1MACH(1)) = ) WRITE( STDOUT, EFMT ) CCPLUS, XR 7009 CONTINUE C XR = -RMACH(2) XR = -XR IF( XR .EQ. RMACH(2) ) GOTO 7019 WRITE( STDOUT, 7011 ) 7011 FORMAT(29H0-(-R1MACH(2)) .NE. R1MACH(2)) WRITE( STDOUT, 7012 ) 7012 FORMAT(16H R1MACH(2) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2) WRITE( STDOUT, 7013 ) 7013 FORMAT(16H -(-R1MACH(2)) = ) WRITE( STDOUT, EFMT ) CCPLUS, XR 7019 CONTINUE C C NOW SEE IF DOUBLE-PRECISION IS CLOSED UNDER NEGATION C XD = -DMACH(1) XD = -XD IF( XD .EQ. DMACH(1) ) GOTO 8009 WRITE( STDOUT, 8001 ) 8001 FORMAT(29H0-(-D1MACH(1)) .NE. D1MACH(1)) WRITE( STDOUT, 8002 ) 8002 FORMAT(16H D1MACH(1) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1) WRITE( STDOUT, 8003 ) 8003 FORMAT(16H -(-D1MACH(1)) = ) WRITE( STDOUT, DFMT ) CCPLUS, XD 8009 CONTINUE C XD = -DMACH(2) XD = -XD IF( XD .EQ. DMACH(2) ) GOTO 8019 WRITE( STDOUT, 8011 ) 8011 FORMAT(29H0-(-D1MACH(2)) .NE. D1MACH(2)) WRITE( STDOUT, 8012 ) 8012 FORMAT(16H D1MACH(2) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2) WRITE( STDOUT, 8013 ) 8013 FORMAT(16H -(-D1MACH(2)) = ) WRITE( STDOUT, DFMT ) CCPLUS, XD 8019 CONTINUE C C CHECK THAT SQRT AND DSQRT WORK NEAR OVER- AND UNDERFLOW LIMITS. C N = IMACH(11)/2 + 1 XR = SQRT(RMACH(1)) IF (XR .GT. 0.0) GO TO 9002 WRITE( STDOUT, 9001 ) 9001 FORMAT(18H SQRT(R1MACH(1)) =) WRITE( STDOUT, EFMT ) CCPLUS, XR GO TO 9004 C SCALE TO AVOID TROUBLE FROM UNDERFLOW... 9002 XR = S2MACH( XR, IMACH(10), N) YR = S2MACH( RMACH(1), IMACH(10), 2*N) YR = ABS(XR*XR - YR) / YR IF (YR .LT. 2.*RMACH(4)) GO TO 9004 WRITE( STDOUT, 9003 ) 9003 FORMAT(35H EXCESSIVE ERROR IN SQRT(R1MACH(1))/13H REL. ERROR =) WRITE( STDOUT, EFMT ) CCPLUS, YR 9004 XR = SQRT(RMACH(2)) IF (XR .GT. 0.0) GO TO 9006 WRITE( STDOUT, 9005 ) 9005 FORMAT(18H SQRT(R1MACH(2)) =) WRITE( STDOUT, EFMT ) CCPLUS, XR GO TO 9008 C SCALE TO AVOID TROUBLE FROM OVERFLOW... 9006 XR = S2MACH( XR, IMACH(10), -N) YR = S2MACH( RMACH(2), IMACH(10), -2*N) YR = ABS(XR*XR - YR) / YR IF (YR .LT. 2.*RMACH(4)) GO TO 9008 WRITE( STDOUT, 9007 ) 9007 FORMAT(35H EXCESSIVE ERROR IN SQRT(R1MACH(2))/13H REL. ERROR =) WRITE( STDOUT, EFMT ) CCPLUS, YR C 9008 N = IMACH(14)/2 + 1 XD = DSQRT(DMACH(1)) IF (XD .GT. 0.D0) GO TO 9010 WRITE( STDOUT, 9009 ) 9009 FORMAT(19H DSQRT(D1MACH(1)) =) WRITE( STDOUT, DFMT ) CCPLUS, XD GO TO 9012 C AGAIN SCALE TO AVOID TROUBLE FROM UNDERFLOW... 9010 XD = S3MACH( XD, IMACH(10), N) YD = S3MACH( DMACH(1), IMACH(10), 2*N) YD = DABS(XD*XD - YD) / YD IF (YD .LT. 2.D0*DMACH(4)) GO TO 9012 WRITE( STDOUT, 9011 ) 9011 FORMAT(36H EXCESSIVE ERROR IN DSQRT(D1MACH(1))/13H REL. ERROR =) WRITE( STDOUT, EFMT ) CCPLUS, YD 9012 XD = DSQRT(DMACH(2)) IF (XD .GT. 0.0D0) GO TO 9014 WRITE( STDOUT, 9013 ) 9013 FORMAT(19H DSQRT(D1MACH(2)) =) WRITE( STDOUT, EFMT ) CCPLUS, XD GO TO 9016 C AGAIN SCALE TO AVOID TROUBLE FROM OVERFLOW... 9014 XD = S3MACH( XD, IMACH(10), -N) YD = S3MACH( DMACH(2), IMACH(10), -2*N) YD = DABS(XD*XD - YD) / YD IF (YD .LT. 2.D0*DMACH(4)) GO TO 9016 WRITE( STDOUT, 9015 ) 9015 FORMAT(36H EXCESSIVE ERROR IN DSQRT(D1MACH(2))/13H REL. ERROR =) WRITE( STDOUT, EFMT ) CCPLUS, YD 9016 RETURN C END REAL FUNCTION S2MACH( XR, BASE, EXP ) C C S2MACH = XR * BASE**EXP C C (17-JUN-85) -- REVISED TO MAKE OVERFLOW LESS LIKELY INTEGER BASE, EXP REAL TBASE, XR C TBASE = FLOAT(BASE) S2MACH = XR C N = EXP IF( N .GE. 0 ) GO TO 20 C N = -N TBASE = 1.0/TBASE C 20 IF( MOD(N,2) .NE. 0 ) S2MACH = S2MACH*TBASE N = N/2 IF( N .LT. 2 ) GO TO 30 TBASE = TBASE * TBASE GO TO 20 C 30 IF (N .EQ. 1) S2MACH = (S2MACH * TBASE) * TBASE RETURN C END SUBROUTINE S3GRD(ALPHA, B, D, ETA0, FX, G, IRC, P, W, X) C C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME *** C C *** PARAMETERS *** C INTEGER IRC, P REAL ALPHA(P), B(2,P), D(P), ETA0, FX, G(P), W(6), 1 X(P) C C....................................................................... C C *** PURPOSE *** C C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER- C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY C REVERSE COMMUNICATION. C C *** PARAMETER DESCRIPTION *** C C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X). C B IN ARRAY OF SIMPLE LOWER AND UPPER BOUNDS ON X. X MUST C SATISFY B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P. C FOR ALL I WITH B(1,I) .GE. B(2,I), S3GRD SIMPLY C SETS G(I) TO 0. C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,P, ARE IN C COMPARABLE UNITS. C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE... C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE C ABS(E) .LE. ETA0. C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL C VALUE, THE ONE IT HAD WHEN S3GRD WAS LAST CALLED WITH C IRC = 0. C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE C PREVIOUS ITERATE. WHEN S3GRD RETURNS WITH IRC = 0, G IS C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE C GRADIENT AT X. C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON S3GRD, C THE CALLER MUST SET IRC TO 0. WHENEVER S3GRD RETURNS A C NONZERO VALUE (OF AT MOST P) FOR IRC, IT HAS PERTURBED C SOME COMPONENT OF X... THE CALLER SHOULD EVALUATE F(X) C AND CALL S3GRD AGAIN WITH FX = F(X). IF B PREVENTS C ESTIMATING G(I) I.E., IF THERE IS AN I WITH C B(1,I) .LT. B(2,I) BUT WITH B(1,I) SO CLOSE TO B(2,I) C THAT THE FINITE-DIFFERENCING STEPS CANNOT BE CHOSEN, C THEN S3GRD RETURNS WITH IRC .GT. P. C P IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F C DEPENDS. C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE C (THE ONE IT HAD WHEN S3GRD WAS LAST CALLED WITH IRC = 0) C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION. C W I/O WORK VECTOR OF LENGTH 6 IN WHICH S3GRD SAVES CERTAIN C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A C PERTURBED X. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION). C C *** ALGORITHM NOTES *** C C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1) C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980). C C *** GENERAL *** C C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND C MCS-7906671. C C....................................................................... C C ***** EXTERNAL FUNCTION ***** C REAL R7MDC EXTERNAL R7MDC C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C C ***** INTRINSIC FUNCTIONS ***** C/+ REAL SQRT C/ C ***** LOCAL VARIABLES ***** C LOGICAL HIT INTEGER FH, FX0, HSAVE, I, XISAVE REAL AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR, 1 DISCON, ETA, GI, H, HMIN, XI, XIH REAL C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002, 1 THREE, TWO, ZERO C C/6 C DATA C2000/2.0E+3/, FOUR/4.0E+0/, HMAX0/0.02E+0/, HMIN0/5.0E+1/, C 1 ONE/1.0E+0/, P002/0.002E+0/, THREE/3.0E+0/, C 2 TWO/2.0E+0/, ZERO/0.0E+0/ C/7 PARAMETER (C2000=2.0E+3, FOUR=4.0E+0, HMAX0=0.02E+0, HMIN0=5.0E+1, 1 ONE=1.0E+0, P002=0.002E+0, THREE=3.0E+0, 2 TWO=2.0E+0, ZERO=0.0E+0) C/ C/6 C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/ C/7 PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C/ C C--------------------------------- BODY ------------------------------ C IF (IRC) 80, 10, 210 C C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS *** C C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE C SQUARE-ROOT OF MACHEP. C 10 W(1) = R7MDC(3) W(2) = SQRT(W(1)) C W(FX0) = FX C C *** INCREMENT I AND START COMPUTING G(I) *** C 20 I = IABS(IRC) + 1 IF (I .GT. P) GO TO 220 IRC = I IF (B(1,I) .LT. B(2,I)) GO TO 30 G(I) = ZERO GO TO 20 30 AFX = ABS(W(FX0)) MACHEP = W(1) H0 = W(2) HMIN = HMIN0 * MACHEP XI = X(I) W(XISAVE) = XI AXI = ABS(XI) AXIBAR = AMAX1(AXI, ONE/D(I)) GI = G(I) AGI = ABS(GI) ETA = ABS(ETA0) IF (AFX .GT. ZERO) ETA = AMAX1(ETA, AGI*AXI*MACHEP/AFX) ALPHAI = ALPHA(I) IF (ALPHAI .EQ. ZERO) GO TO 130 IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 140 AFXETA = AFX*ETA AAI = ABS(ALPHAI) C C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE. C IF (GI**2 .LE. AFXETA*AAI) GO TO 40 H = TWO* SQRT(AFXETA/AAI) H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI)) GO TO 50 C40 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE) 40 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE) H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI)) C C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL *** C 50 H = AMAX1(H, HMIN*AXIBAR) C C *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT C *** MOST 10**-3. C IF (AAI*H .LE. P002*AGI) GO TO 120 C C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE. C DISCON = C2000*AFXETA H = DISCON/(AGI + SQRT(GI**2 + AAI*DISCON)) C C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG *** C H = AMAX1(H, HMIN*AXIBAR) IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE) C C *** COMPUTE CENTRAL DIFFERENCE *** C XIH = XI + H IF (XI - H .LT. B(1,I)) GO TO 60 IRC = -I IF (XIH .LE. B(2,I)) GO TO 200 H = -H XIH = XI + H IF (XI + TWO*H .LT. B(1,I)) GO TO 190 GO TO 70 60 IF (XI + TWO*H .GT. B(2,I)) GO TO 190 C *** MUST DO OFF-SIDE CENTRAL DIFFERENCE *** 70 IRC = -(I + P) GO TO 200 C 80 I = -IRC IF (I .LE. P) GO TO 100 I = I - P IF (I .GT. P) GO TO 90 W(FH) = FX H = TWO * W(HSAVE) XIH = W(XISAVE) + H IRC = IRC - P GO TO 200 C C *** FINISH OFF-SIDE CENTRAL DIFFERENCE *** C 90 I = I - P G(I) = (FOUR*W(FH) - FX - THREE*W(FX0)) / W(HSAVE) IRC = I X(I) = W(XISAVE) GO TO 20 C 100 H = -W(HSAVE) IF (H .GT. ZERO) GO TO 110 W(FH) = FX XIH = W(XISAVE) + H GO TO 200 C 110 G(I) = (W(FH) - FX) / (TWO * H) X(I) = W(XISAVE) GO TO 20 C C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES *** C 120 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR IF (ALPHAI*GI .LT. ZERO) H = -H GO TO 150 130 H = AXIBAR GO TO 150 140 H = H0 * AXIBAR C 150 HIT = .FALSE. 160 XIH = XI + H IF (H .GT. ZERO) GO TO 170 IF (XIH .GE. B(1,I)) GO TO 200 GO TO 180 170 IF (XIH .LE. B(2,I)) GO TO 200 180 IF (HIT) GO TO 190 HIT = .TRUE. H = -H GO TO 160 C C *** ERROR RETURN... 190 IRC = I + P GO TO 230 C C *** RETURN FOR NEW FUNCTION VALUE... 200 X(I) = XIH W(HSAVE) = H GO TO 999 C C *** COMPUTE ACTUAL FORWARD DIFFERENCE *** C 210 G(IRC) = (FX - W(FX0)) / W(HSAVE) X(IRC) = W(XISAVE) GO TO 20 C C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED *** C 220 IRC = 0 230 FX = W(FX0) C 999 RETURN C *** LAST LINE OF S3GRD FOLLOWS *** END DOUBLE PRECISION FUNCTION S3MACH( XD, BASE, EXP ) C C S3MACH = XD * BASE**EXP C C (17-JUN-85) -- REVISED TO MAKE OVERFLOW LESS LIKELY INTEGER BASE, EXP DOUBLE PRECISION TBASE, XD C TBASE = FLOAT(BASE) S3MACH = XD C N = EXP IF( N .GE. 0 ) GO TO 20 C N = -N TBASE = 1.0D0/TBASE C 20 IF( MOD(N,2) .NE. 0 ) S3MACH = S3MACH*TBASE N = N/2 IF( N .LT. 2 ) GO TO 30 TBASE = TBASE * TBASE GO TO 20 C 30 IF (N .EQ. 1) S3MACH = (S3MACH * TBASE) * TBASE RETURN C END SUBROUTINE S7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS, 1 P, P1, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE BOUNDED MODIFIED NEWTON STEP *** C INTEGER KB, LV, NS, P, P1 INTEGER IPIV(P), IPIV1(P), IPIV2(P) REAL B(2,P), D(P), DST(P), L(1), 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P), 2 X0(P) C DIMENSION L(P*(P+1)/2) C REAL D7TPR, R7MDC, V2NRM EXTERNAL D7TPR, I7SHFT, L7ITV, L7IVM, Q7RSH, R7MDC, V2NRM, 1 V2AXY, V7CPY, V7IPR, V7SCP, V7SHF C C *** LOCAL VARIABLES *** C INTEGER I, J, K, P0, P1M1 REAL ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T, 1 TI, T1, XI REAL FUDGE, HALF, MEPS2, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR C C/6 C DATA DSTNRM/2/, GTSTEP/4/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, C 1 RADIUS/8/, STPPAR/5/ C/7 PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7, 1 RADIUS=8, STPPAR=5) SAVE MEPS2 C/ C DATA FUDGE/1.0001E+0/, HALF/0.5E+0/, MEPS2/0.E+0/, 1 ONE/1.0E+0/, TWO/2.E+0/, ZERO/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C DSTMAX = FUDGE * (ONE + V(PHMXFC)) * V(RADIUS) DSTMIN = (ONE + V(PHMNFC)) * V(RADIUS) DST1 = ZERO IF (MEPS2 .LE. ZERO) MEPS2 = TWO * R7MDC(3) P0 = P1 NS = 0 DO 10 I = 1, P IPIV1(I) = I IPIV2(I) = I 10 CONTINUE DO 20 I = 1, P1 20 W(I) = -STEP(I) * TD(I) ALPHA = ABS(V(STPPAR)) V(PREDUC) = ZERO GTS = -V(GTSTEP) IF (KB .LT. 0) CALL V7SCP(P, DST, ZERO) KB = 1 C C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D. C C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE. C 30 T = ONE K = 0 DO 60 I = 1, P1 J = IPIV(I) DX = W(I) / D(J) XI = X(J) - DX IF (XI .LT. B(1,J)) GO TO 40 IF (XI .LE. B(2,J)) GO TO 60 TI = ( X(J) - B(2,J) ) / DX K = I GO TO 50 40 TI = ( X(J) - B(1,J) ) / DX K = -I 50 IF (T .LE. TI) GO TO 60 T = TI 60 CONTINUE C IF (P .GT. P1) CALL V7CPY(P-P1, STEP(P1+1), DST(P1+1)) CALL V2AXY(P1, STEP, -T, W, DST) DST0 = DST1 DST1 = V2NRM(P, STEP) C C *** CHECK FOR OVERSIZE STEP *** C IF (DST1 .LE. DSTMAX) GO TO 80 IF (P1 .GE. P0) GO TO 70 IF (DST0 .LT. DSTMIN) KB = 0 GO TO 110 C 70 K = 0 C C *** UPDATE DST, TG, AND V(PREDUC) *** C 80 V(DSTNRM) = DST1 CALL V7CPY(P1, DST, STEP) T1 = ONE - T DO 90 I = 1, P1 90 TG(I) = T1 * TG(I) IF (ALPHA .GT. ZERO) CALL V2AXY(P1, TG, T*ALPHA, W, TG) V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS + 1 HALF*ALPHA*T* D7TPR(P1,W,W)) IF (K .EQ. 0) GO TO 110 C C *** PERMUTE L, ETC. IF NECESSARY *** C P1M1 = P1 - 1 J = IABS(K) IF (J .EQ. P1) GO TO 100 NS = NS + 1 IPIV2(P1) = J CALL Q7RSH(J, P1, .FALSE., TG, L, W) CALL I7SHFT(P1, J, IPIV) CALL I7SHFT(P1, J, IPIV1) CALL V7SHF(P1, J, TG) CALL V7SHF(P1, J, DST) 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1) P1 = P1M1 IF (P1 .LE. 0) GO TO 110 CALL L7IVM(P1, W, L, TG) GTS = D7TPR(P1, W, W) CALL L7ITV(P1, W, L, W) GO TO 30 C C *** UNSCALE STEP *** C 110 DO 120 I = 1, P J = IABS(IPIV(I)) STEP(J) = DST(I) / D(J) 120 CONTINUE C C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS C *** TO THEIR BOUNDS *** C IF (P1 .GE. P0) GO TO 150 K = P1 + 1 DO 140 I = K, P0 J = IPIV(I) T = MEPS2 IF (J .GT. 0) GO TO 130 T = -T J = -J IPIV(I) = J 130 T = T * AMAX1( ABS(X(J)), ABS(X0(J))) STEP(J) = STEP(J) + T 140 CONTINUE C 150 CALL V2AXY(P, X, ONE, STEP, X0) IF (NS .GT. 0) CALL V7IPR(P0, IPIV1, TD) 999 RETURN C *** LAST LINE OF S7BQN FOLLOWS *** END SUBROUTINE S7CPR(C, IV, L, LIV) C C *** PRINT C FOR NSG (ETC.) *** C INTEGER L, LIV INTEGER IV(LIV) REAL C(L) C INTEGER I, PU C INTEGER PRUNIT, SOLPRT C C/6 C DATA PRUNIT/21/, SOLPRT/22/ C/7 PARAMETER (PRUNIT=21, SOLPRT=22) C/ C *** BODY *** C IF (IV(1) .GT. 11) GO TO 999 IF (IV(SOLPRT) .EQ. 0) GO TO 999 PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (L .GT. 0) WRITE(PU,10) (I, C(I), I = 1, L) 10 FORMAT(/21H LINEAR PARAMETERS...//(1X,I5,E16.6)) C 999 RETURN C *** LAST LINE OF S7CPR FOLLOWS *** END SUBROUTINE S7DMP(N, X, Y, Z, K) C C *** SET X = DIAG(Z)**K * Y * DIAG(Z)**K C *** FOR X, Y = COMPACTLY STORED LOWER TRIANG. MATRICES C *** K = 1 OR -1. C INTEGER N, K C/6S C REAL X(1), Y(1), Z(N) C/7S REAL X(*), Y(*), Z(N) C/ INTEGER I, J, L REAL ONE, T DATA ONE/1.E+0/ C L = 1 IF (K .GE. 0) GO TO 30 DO 20 I = 1, N T = ONE / Z(I) DO 10 J = 1, I X(L) = T * Y(L) / Z(J) L = L + 1 10 CONTINUE 20 CONTINUE GO TO 999 C 30 DO 50 I = 1, N T = Z(I) DO 40 J = 1, I X(L) = T * Y(L) * Z(J) L = L + 1 40 CONTINUE 50 CONTINUE 999 RETURN C *** LAST CARD OF S7DMP FOLLOWS *** END SUBROUTINE S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA) INTEGER M,N INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),IWA(M) C ********** C C SUBROUTINE S7ETR C C GIVEN A COLUMN-ORIENTED DEFINITION OF THE SPARSITY PATTERN C OF AN M BY N MATRIX A, THIS SUBROUTINE DETERMINES A C ROW-ORIENTED DEFINITION OF THE SPARSITY PATTERN OF A. C C ON INPUT THE COLUMN-ORIENTED DEFINITION IS SPECIFIED BY C THE ARRAYS INDROW AND JPNTR. ON OUTPUT THE ROW-ORIENTED C DEFINITION IS SPECIFIED BY THE ARRAYS INDCOL AND IPNTR. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW C INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. C THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO C ELEMENTS OF THE MATRIX A. C C INDCOL IS AN INTEGER OUTPUT ARRAY WHICH CONTAINS THE C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. C C IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. C THE COLUMN INDICES FOR ROW I ARE C C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. C C NOTE THAT IPNTR(1) IS SET TO 1 AND THAT IPNTR(M+1)-1 IS C THEN THE NUMBER OF NON-ZERO ELEMENTS OF THE MATRIX A. C C IWA IS AN INTEGER WORK ARRAY OF LENGTH M. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER IR,JCOL,JP,JPL,JPU,L,NNZ C C DETERMINE THE NUMBER OF NON-ZEROES IN THE ROWS. C DO 10 IR = 1, M IWA(IR) = 0 10 CONTINUE NNZ = JPNTR(N+1) - 1 DO 20 JP = 1, NNZ IR = INDROW(JP) IWA(IR) = IWA(IR) + 1 20 CONTINUE C C SET POINTERS TO THE START OF THE ROWS IN INDCOL. C IPNTR(1) = 1 DO 30 IR = 1, M IPNTR(IR+1) = IPNTR(IR) + IWA(IR) IWA(IR) = IPNTR(IR) 30 CONTINUE C C FILL INDCOL. C DO 60 JCOL = 1, N JPL = JPNTR(JCOL) JPU = JPNTR(JCOL+1) - 1 IF (JPU .LT. JPL) GO TO 50 DO 40 JP = JPL, JPU IR = INDROW(JP) L = IWA(IR) INDCOL(L) = JCOL IWA(IR) = IWA(IR) + 1 40 CONTINUE 50 CONTINUE 60 CONTINUE RETURN C C LAST CARD OF SUBROUTINE S7ETR. C END SUBROUTINE S7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X) C C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME *** C C *** PARAMETERS *** C INTEGER IRC, N REAL ALPHA(N), D(N), ETA0, FX, G(N), W(6), X(N) C C....................................................................... C C *** PURPOSE *** C C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER- C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY C REVERSE COMMUNICATION. C C *** PARAMETER DESCRIPTION *** C C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X). C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,N, ARE IN C COMPARABLE UNITS. C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE... C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE C ABS(E) .LE. ETA0. C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL C VALUE, THE ONE IT HAD WHEN S7GRD WAS LAST CALLED WITH C IRC = 0. C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE C PREVIOUS ITERATE. WHEN S7GRD RETURNS WITH IRC = 0, G IS C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE C GRADIENT AT X. C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON S7GRD, C THE CALLER MUST SET IRC TO 0. WHENEVER S7GRD RETURNS A C NONZERO VALUE FOR IRC, IT HAS PERTURBED SOME COMPONENT OF C X... THE CALLER SHOULD EVALUATE F(X) AND CALL S7GRD C AGAIN WITH FX = F(X). C N IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F C DEPENDS. C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE C (THE ONE IT HAD WHEN S7GRD WAS LAST CALLED WITH IRC = 0) C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION. C W I/O WORK VECTOR OF LENGTH 6 IN WHICH S7GRD SAVES CERTAIN C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A C PERTURBED X. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION). C C *** ALGORITHM NOTES *** C C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1) C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980). C C *** GENERAL *** C C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND C MCS-7906671. C C....................................................................... C C ***** EXTERNAL FUNCTION ***** C REAL R7MDC EXTERNAL R7MDC C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C C ***** INTRINSIC FUNCTIONS ***** C/+ REAL SQRT C/ C ***** LOCAL VARIABLES ***** C INTEGER FH, FX0, HSAVE, I, XISAVE REAL AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR, 1 DISCON, ETA, GI, H, HMIN REAL C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002, 1 THREE, TWO, ZERO C C/6 C DATA C2000/2.0E+3/, FOUR/4.0E+0/, HMAX0/0.02E+0/, HMIN0/5.0E+1/, C 1 ONE/1.0E+0/, P002/0.002E+0/, THREE/3.0E+0/, C 2 TWO/2.0E+0/, ZERO/0.0E+0/ C/7 PARAMETER (C2000=2.0E+3, FOUR=4.0E+0, HMAX0=0.02E+0, HMIN0=5.0E+1, 1 ONE=1.0E+0, P002=0.002E+0, THREE=3.0E+0, 2 TWO=2.0E+0, ZERO=0.0E+0) C/ C/6 C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/ C/7 PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C/ C C--------------------------------- BODY ------------------------------ C IF (IRC) 140, 100, 210 C C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS *** C C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE C SQUARE-ROOT OF MACHEP. C 100 W(1) = R7MDC(3) W(2) = SQRT(W(1)) C W(FX0) = FX C C *** INCREMENT I AND START COMPUTING G(I) *** C 110 I = IABS(IRC) + 1 IF (I .GT. N) GO TO 300 IRC = I AFX = ABS(W(FX0)) MACHEP = W(1) H0 = W(2) HMIN = HMIN0 * MACHEP W(XISAVE) = X(I) AXI = ABS(X(I)) AXIBAR = AMAX1(AXI, ONE/D(I)) GI = G(I) AGI = ABS(GI) ETA = ABS(ETA0) IF (AFX .GT. ZERO) ETA = AMAX1(ETA, AGI*AXI*MACHEP/AFX) ALPHAI = ALPHA(I) IF (ALPHAI .EQ. ZERO) GO TO 170 IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 180 AFXETA = AFX*ETA AAI = ABS(ALPHAI) C C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE. C IF (GI**2 .LE. AFXETA*AAI) GO TO 120 H = TWO* SQRT(AFXETA/AAI) H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI)) GO TO 130 C120 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE) 120 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE) H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI)) C C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL *** C 130 H = AMAX1(H, HMIN*AXIBAR) C C *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT C *** MOST 10**-3. C IF (AAI*H .LE. P002*AGI) GO TO 160 C C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE. C DISCON = C2000*AFXETA H = DISCON/(AGI + SQRT(GI**2 + AAI*DISCON)) C C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG *** C H = AMAX1(H, HMIN*AXIBAR) IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE) C C *** COMPUTE CENTRAL DIFFERENCE *** C IRC = -I GO TO 200 C 140 H = -W(HSAVE) I = IABS(IRC) IF (H .GT. ZERO) GO TO 150 W(FH) = FX GO TO 200 C 150 G(I) = (W(FH) - FX) / (TWO * H) X(I) = W(XISAVE) GO TO 110 C C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES *** C 160 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR IF (ALPHAI*GI .LT. ZERO) H = -H GO TO 200 170 H = AXIBAR GO TO 200 180 H = H0 * AXIBAR C 200 X(I) = W(XISAVE) + H W(HSAVE) = H GO TO 999 C C *** COMPUTE ACTUAL FORWARD DIFFERENCE *** C 210 G(IRC) = (FX - W(FX0)) / W(HSAVE) X(IRC) = W(XISAVE) GO TO 110 C C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED *** C 300 FX = W(FX0) IRC = 0 C 999 RETURN C *** LAST CARD OF S7GRD FOLLOWS *** END SUBROUTINE S7IPR(P, IP, H) C C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H. C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)). C INTEGER P INTEGER IP(P) REAL H(1) C INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M REAL T C C *** BODY *** C DO 90 I = 1, P J = IP(I) IF (J .EQ. I) GO TO 90 IP(I) = IABS(J) IF (J .LT. 0) GO TO 90 K = I 10 J1 = J K1 = K IF (J .LE. K) GO TO 20 J1 = K K1 = J 20 KMJ = K1-J1 L = J1-1 JM = J1*L/2 KM = K1*(K1-1)/2 IF (L .LE. 0) GO TO 40 DO 30 M = 1, L JM = JM+1 T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 30 CONTINUE 40 KM = KM+1 KK = KM+KMJ JM = JM+1 T = H(JM) H(JM) = H(KK) H(KK) = T J1 = L L = KMJ-1 IF (L .LE. 0) GO TO 60 DO 50 M = 1, L JM = JM+J1+M T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 50 CONTINUE 60 IF (K1 .GE. P) GO TO 80 L = P-K1 K1 = K1-1 KM = KK DO 70 M = 1, L KM = KM+K1+M JM = KM-KMJ T = H(JM) H(JM) = H(KM) H(KM) = T 70 CONTINUE 80 K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 10 90 CONTINUE 999 RETURN C *** LAST LINE OF S7IPR FOLLOWS *** END SUBROUTINE S7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, 1 Y) C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL A(1), COSMIN, SIZE, STEP(P), U(P), W(P), 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, J, K REAL DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** REAL HALF, ONE, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL D7TPR, S7LVM, V2NRM C C/6 C DATA HALF/0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ONE=1.E+0, ZERO=0.E+0) C/ C C----------------------------------------------------------------------- C SDOTWM = D7TPR(P, STEP, WCHMTD) DENMIN = COSMIN * V2NRM(P,STEP) * V2NRM(P,WCHMTD) WSCALE = ONE IF (DENMIN .NE. ZERO) WSCALE = AMIN1(ONE, ABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL S7LVM(P, U, A, STEP) T = HALF * (SIZE * D7TPR(P, STEP, U) - D7TPR(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF S7LUP FOLLOWS *** END SUBROUTINE S7LVM(P, Y, S, X) C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, J, K REAL XI C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTION *** C REAL D7TPR EXTERNAL D7TPR C C----------------------------------------------------------------------- C J = 1 DO 10 I = 1, P Y(I) = D7TPR(I, S(J), X) J = J + I 10 CONTINUE C IF (P .LE. 1) GO TO 999 J = 1 DO 40 I = 2, P XI = X(I) IM1 = I - 1 J = J + 1 DO 30 K = 1, IM1 Y(K) = Y(K) + S(J)*XI J = J + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF S7LVM FOLLOWS *** END SUBROUTINE S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA) INTEGER N,NNZ INTEGER INDROW(NNZ),INDCOL(NNZ),JPNTR(1),IWA(N) C ********** C C SUBROUTINE S7RTDT C C GIVEN THE NON-ZERO ELEMENTS OF AN M BY N MATRIX A IN C ARBITRARY ORDER AS SPECIFIED BY THEIR ROW AND COLUMN C INDICES, THIS SUBROUTINE PERMUTES THESE ELEMENTS SO C THAT THEIR COLUMN INDICES ARE IN NON-DECREASING ORDER. C C ON INPUT IT IS ASSUMED THAT THE ELEMENTS ARE SPECIFIED IN C C INDROW(K),INDCOL(K), K = 1,...,NNZ. C C ON OUTPUT THE ELEMENTS ARE PERMUTED SO THAT INDCOL IS C IN NON-DECREASING ORDER. IN ADDITION, THE ARRAY JPNTR C IS SET SO THAT THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT THE VALUE OF M IS NOT NEEDED BY S7RTDT AND IS C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C NNZ IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF NON-ZERO ELEMENTS OF A. C C INDROW IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDROW C MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A. C ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING C COLUMN INDICES OF INDCOL ARE IN NON-DECREASING ORDER. C C INDCOL IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDCOL C MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS C OF A. ON OUTPUT INDCOL IS PERMUTED SO THAT THESE INDICES C ARE IN NON-DECREASING ORDER. C C JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN THE OUTPUT C INDROW. THE ROW INDICES FOR COLUMN J ARE C C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. C C NOTE THAT JPNTR(1) IS SET TO 1 AND THAT JPNTR(N+1)-1 C IS THEN NNZ. C C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... MAX0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982. C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE C C ********** INTEGER I,J,K,L C C DETERMINE THE NUMBER OF NON-ZEROES IN THE COLUMNS. C DO 10 J = 1, N IWA(J) = 0 10 CONTINUE DO 20 K = 1, NNZ J = INDCOL(K) IWA(J) = IWA(J) + 1 20 CONTINUE C C SET POINTERS TO THE START OF THE COLUMNS IN INDROW. C JPNTR(1) = 1 DO 30 J = 1, N JPNTR(J+1) = JPNTR(J) + IWA(J) IWA(J) = JPNTR(J) 30 CONTINUE K = 1 C C BEGIN IN-PLACE SORT. C 40 CONTINUE J = INDCOL(K) IF (K .LT. JPNTR(J) .OR. K .GE. JPNTR(J+1)) GO TO 50 C C CURRENT ELEMENT IS IN POSITION. NOW EXAMINE THE C NEXT ELEMENT OR THE FIRST UN-SORTED ELEMENT IN C THE J-TH GROUP. C K = MAX0(K+1,IWA(J)) GO TO 60 50 CONTINUE C C CURRENT ELEMENT IS NOT IN POSITION. PLACE ELEMENT C IN POSITION AND MAKE THE DISPLACED ELEMENT THE C CURRENT ELEMENT. C L = IWA(J) IWA(J) = IWA(J) + 1 I = INDROW(K) INDROW(K) = INDROW(L) INDCOL(K) = INDCOL(L) INDROW(L) = I INDCOL(L) = J 60 CONTINUE IF (K .LE. NNZ) GO TO 40 RETURN C C LAST CARD OF SUBROUTINE S7RTDT. C END SUBROUTINE S88FMT( N, W, IFMT ) C C S88FMT REPLACES IFMT(1), ... , IFMT(N) WITH C THE CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT C DIGITS OF W. C INTEGER N,W C/6S C INTEGER IFMT(N) C/7S CHARACTER*1 IFMT(N) C/ C INTEGER NT,WT C C/6S C INTEGER DIGITS(10) C DATA DIGITS( 1) / 1H0 / C DATA DIGITS( 2) / 1H1 / C DATA DIGITS( 3) / 1H2 / C DATA DIGITS( 4) / 1H3 / C DATA DIGITS( 5) / 1H4 / C DATA DIGITS( 6) / 1H5 / C DATA DIGITS( 7) / 1H6 / C DATA DIGITS( 8) / 1H7 / C DATA DIGITS( 9) / 1H8 / C DATA DIGITS(10) / 1H9 / C/7S CHARACTER*1 DIGITS(10) DATA DIGITS( 1) / '0' / DATA DIGITS( 2) / '1' / DATA DIGITS( 3) / '2' / DATA DIGITS( 4) / '3' / DATA DIGITS( 5) / '4' / DATA DIGITS( 6) / '5' / DATA DIGITS( 7) / '6' / DATA DIGITS( 8) / '7' / DATA DIGITS( 9) / '8' / DATA DIGITS(10) / '9' / C/ C NT = N WT = W C 10 IF (NT .LE. 0) RETURN IDIGIT = MOD( WT, 10 ) IFMT(NT) = DIGITS(IDIGIT+1) WT = WT/10 NT = NT - 1 GO TO 10 C END SUBROUTINE SDUMP C THIS IS THE STANDARD DUMP ROUTINE FOR THE PORT LIBRARY. C FIRST IT PROVIDES A FORMATTED DUMP OF THE PORT STACK. C THEN IT CALLS THE LOCAL (PREFERABLY SYMBOLIC) DUMP ROUTINE. CALL STKDMP CALL FDUMP RETURN END SUBROUTINE SETC(N,V,B) C C SETC SETS THE N COMPLEX ITEMS IN B TO V C C/R C REAL B(2,N), V(2), V1, V2 C V1 = V(1) C V2 = V(2) C/C COMPLEX B(1),V C/ C IF(N .LE. 0) RETURN C DO 10 I = 1, N C/R C B(1,I) = V1 C10 B(2,I) = V2 C/C 10 B(I) = V C/ C RETURN C END SUBROUTINE SETD(N,V,B) C C SETD SETS THE N DOUBLE PRECISION ITEMS IN B TO V C DOUBLE PRECISION B(1),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETERR(MESSG,NMESSG,NERR,IOPT) C C SETERR SETS LERROR = NERR, OPTIONALLY PRINTS THE MESSAGE AND DUMPS C ACCORDING TO THE FOLLOWING RULES... C C IF IOPT = 1 AND RECOVERING - JUST REMEMBER THE ERROR. C IF IOPT = 1 AND NOT RECOVERING - PRINT AND STOP. C IF IOPT = 2 - PRINT, DUMP AND STOP. C C INPUT C C MESSG - THE ERROR MESSAGE. C NMESSG - THE LENGTH OF THE MESSAGE, IN CHARACTERS. C NERR - THE ERROR NUMBER. MUST HAVE NERR NON-ZERO. C IOPT - THE OPTION. MUST HAVE IOPT=1 OR 2. C C ERROR STATES - C C 1 - MESSAGE LENGTH NOT POSITIVE. C 2 - CANNOT HAVE NERR=0. C 3 - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR. C 4 - BAD VALUE FOR IOPT. C C ONLY THE FIRST 72 CHARACTERS OF THE MESSAGE ARE PRINTED. C C THE ERROR HANDLER CALLS A SUBROUTINE NAMED SDUMP TO PRODUCE A C SYMBOLIC DUMP. C C/6S C INTEGER MESSG(1) C/7S CHARACTER*1 MESSG(NMESSG) C/ C C THE UNIT FOR ERROR MESSAGES. C IWUNIT=I1MACH(4) C IF (NMESSG.GE.1) GO TO 10 C C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. C WRITE(IWUNIT,9000) 9000 FORMAT(52H1ERROR 1 IN SETERR - MESSAGE LENGTH NOT POSITIVE.) GO TO 60 C C NW IS THE NUMBER OF WORDS THE MESSAGE OCCUPIES. C (I1MACH(6) IS THE NUMBER OF CHARACTERS PER WORD.) C C/6S C10 NW=(MIN0(NMESSG,72)-1)/I1MACH(6)+1 C/7S 10 NW= MIN0(NMESSG,72) C/ C IF (NERR.NE.0) GO TO 20 C C CANNOT TURN THE ERROR STATE OFF USING SETERR. C (I8SAVE SETS A FATAL ERROR HERE.) C WRITE(IWUNIT,9001) 9001 FORMAT(42H1ERROR 2 IN SETERR - CANNOT HAVE NERR=0// 1 34H THE CURRENT ERROR MESSAGE FOLLOWS///) CALL E9RINT(MESSG,NW,NERR,.TRUE.) ITEMP=I8SAVE(1,1,.TRUE.) GO TO 50 C C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. C 20 IF (I8SAVE(1,NERR,.TRUE.).EQ.0) GO TO 30 C WRITE(IWUNIT,9002) 9002 FORMAT(23H1ERROR 3 IN SETERR -, 1 48H AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.// 2 48H THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.///) CALL EPRINT CALL E9RINT(MESSG,NW,NERR,.TRUE.) GO TO 50 C C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. C 30 CALL E9RINT(MESSG,NW,NERR,.TRUE.) C IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 C C MUST HAVE IOPT = 1 OR 2. C WRITE(IWUNIT,9003) 9003 FORMAT(42H1ERROR 4 IN SETERR - BAD VALUE FOR IOPT// 1 34H THE CURRENT ERROR MESSAGE FOLLOWS///) GO TO 50 C C IF THE ERROR IS FATAL, PRINT, DUMP, AND STOP C 40 IF (IOPT.EQ.2) GO TO 50 C C HERE THE ERROR IS RECOVERABLE C C IF THE RECOVERY MODE IS IN EFFECT, OK, JUST RETURN C IF (I8SAVE(2,0,.FALSE.).EQ.1) RETURN C C OTHERWISE PRINT AND STOP C CALL EPRINT STOP C 50 CALL EPRINT 60 CALL SDUMP STOP C END SUBROUTINE SETI(N,V,B) C C SETI SETS THE N INTEGER ITEMS IN B TO V C INTEGER B(1),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETL(N,V,B) C C SETL SETS THE N LOGICAL ITEMS IN B TO V C LOGICAL B(1),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETR(N,V,B) C C SETR SETS THE N REAL ITEMS IN B TO V C REAL B(1),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SMNFB( P, X,B, CALCF, MXFCAL, ACC ) C C ** SIMPLIED VERSION OF MNF C C INPUT PARAMETERS C P NUMBER OF UNKNOWNS C X APPROXIMATE SOLUTION C B FIRST ROW OF B GIVES LOWER BOUNDS ON X AND SECOND GIVES UPPER C BOUNDS C CALCF SUBROUTINE TO EVALUATE FUNCTION C MXFCAL MAXIMUM NUMBER OF PERMITTED FUNCTION EVALUATIONS C ACC ACCURACY IN X C OUTPUT PARAMETERS C X SOLUTION INTEGER P, MXFCAL REAL X(P), ACC ,B(2,P) EXTERNAL CALCF, C6LCF C C C C *** LOCAL VARIABLES *** C INTEGER IV, LIV, LV, V1 INTEGER IDI,IDM1,ID,J REAL DSTAK(1000) COMMON /CSTAK/ DSTAK INTEGER ISTAK(1000) EQUIVALENCE (DSTAK(1), ISTAK(1)) C C *** BODY *** C CALL ENTER(0) C/6S C IF (P.LT.1) C 1CALL SETERR(14H SMNFB- P.LT.1,14,1,2) C IF (MXFCAL.LT.1) C 1CALL SETERR(19H SMNFB- MXFCAL.LT.1,19,2,2) C IF (ACC.LT.0.0) C 1CALL SETERR(18H SMNFB-ACC .LT.0.0,18,3,2) C/7S IF (P.LT.1) 1CALL SETERR(' SMNFB- P.LT.1',14,1,2) IF (MXFCAL.LT.1) 1CALL SETERR(' SMNFB- MXFCAL.LT.1',19,2,2) IF (ACC.LT.0.0) 1CALL SETERR(' SMNFB-ACC .LT.0.0',18,3,2) C/ LIV =59+P LV=77+P*(P+23)/2 IV=ISTKGT(LIV,2) V1=ISTKGT(LV, 3) CALL IVSET(2,ISTAK(IV),LIV,LV,DSTAK(V1)) ISTAK(IV+20)=0 ISTAK(IV+16)=MXFCAL ISTAK(IV+17)=MXFCAL DSTAK(V1+32)=ACC DSTAK(V1+31)=ACC ID=ISTKGT(P, 3) IDM1=ID-1 DO 10 I=1,P IDI=IDM1+I DSTAK(IDI)=1.0 IF (X(I).NE.0.0)DSTAK(IDI)=1.0/ABS(X(I)) 10 CONTINUE CALL MNFB( P, DSTAK(ID),X,B, C6LCF, ISTAK(IV), LIV, LV, 1 DSTAK(V1), IU, UR, CALCF) J=ISTAK(IV) IF(J.LT.7) GO TO 20 C/6S C IF (J.EQ.82)CALL SETERR(26H SMNFB-INCONSISTENT BOUNDS,26,4,1) C IF (J.EQ.7)CALL SETERR(27H SMNFB-SINGULAR CONVERGENCE,27,5,1) C IF(J.EQ.8)CALL SETERR(24H SMNFB-FALSE CONVERGENCE,24,6,1) C IF(J.EQ.9)CALL SETERR(32H SMNFB-FUNCTION EVALUATION LIMIT,32,7,1) C IF (J.EQ.63) C 1CALL SETERR(43H SMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X,43,8,1) C/7S IF (J.EQ.82)CALL SETERR(' SMNFB-INCONSISTENT BOUNDS',26,4,1) IF (J.EQ.7)CALL SETERR(' SMNFB-SINGULAR CONVERGENCE',27,5,1) IF(J.EQ.8)CALL SETERR(' SMNFB-FALSE CONVERGENCE',24,6,1) IF(J.EQ.9)CALL SETERR(' SMNFB-FUNCTION EVALUATION LIMIT',32,7,1) IF (J.EQ.63) 1CALL SETERR(' SMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X',43,8,1) C/ 20 CALL LEAVE C RETURN C *** LAST LINE OF SMNFB FOLLOWS *** END SUBROUTINE SRECAP(IWUNIT) C C WRITES LOUT, LNOW, LUSED AND LMAX ON LOGICAL UNIT IWUNIT. C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) INTEGER ISTATS(4) LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),ISTATS(1)) C DATA INIT/.TRUE./ C CALL I0TK01 IF (INIT) CALL I0TK00(INIT,500,4) C WRITE(IWUNIT,9000) ISTATS C 9000 FORMAT(20H0STACK STATISTICS...// 1 24H OUTSTANDING ALLOCATIONS,I8/ 1 24H CURRENT ACTIVE LENGTH ,I8/ 3 24H MAXIMUM LENGTH USED ,I8/ 4 24H MAXIMUM LENGTH ALLOWED ,I8) C RETURN C END SUBROUTINE STINIT(NITEMS,ISIZE) C CALL I0TK01 CALL ISTKIN(NITEMS,ISIZE+2) C RETURN C END SUBROUTINE STKDMP C C THIS PROCEDURE PROVIDES A DUMP OF THE PORT STACK. C C WRITTEN BY D. D. WARNER. C C MOSTLY REWRITTEN BY P. A. FOX, OCTOBER 13, 1982 C AND COMMENTS ADDED. C C ALLOCATED REGIONS OF THE STACK ARE PRINTED OUT IN THE APPROPRIATE C FORMAT, EXCEPT IF THE STACK APPEARS TO HAVE BEEN OVERWRITTEN. C IF OVERWRITE SEEMS TO HAVE HAPPENED, THE ENTIRE STACK IS PRINTED OUT C IN UNSTRUCTURED FORM, ONCE FOR EACH OF THE POSSIBLE C (LOGICAL, INTEGER, REAL, DOUBLE PRECISION, OR COMPLEX) FORMATS. C COMMON /CSTAK/ DSTAK DOUBLE PRECISION DSTAK(500) REAL RSTAK(1000) C/R C REAL CMSTAK(2,500) C/C COMPLEX CMSTAK(500) C/ INTEGER ISTAK(1000) LOGICAL LSTAK(1000) C INTEGER LOUT, LNOW, LUSED, LMAX, LBOOK INTEGER LLOUT, BPNTR INTEGER IPTR, ERROUT, MCOL, NITEMS INTEGER WR, DR, WD, DD, WI INTEGER LNG(5), ISIZE(5) INTEGER I, LNEXT, ITYPE, I1MACH C LOGICAL INIT, TRBL1, TRBL2 C EQUIVALENCE (DSTAK(1), ISTAK(1)) EQUIVALENCE (DSTAK(1), LSTAK(1)) EQUIVALENCE (DSTAK(1), RSTAK(1)) C/R C EQUIVALENCE (DSTAK(1), CMSTAK(1,1)) C/C EQUIVALENCE (DSTAK(1), CMSTAK(1)) C/ EQUIVALENCE (ISTAK(1), LOUT) EQUIVALENCE (ISTAK(2), LNOW) EQUIVALENCE (ISTAK(3), LUSED) EQUIVALENCE (ISTAK(4), LMAX) EQUIVALENCE (ISTAK(5), LBOOK) EQUIVALENCE (ISTAK(6), ISIZE(1)) C DATA MCOL/132/ DATA INIT/.TRUE./ C C I0TK00 CHECKS TO SEE IF THE FIRST TEN, BOOKKEEPING, LOCATIONS OF C THE STACK HAVE BEEN INITIALIZED (AND DOES IT, IF NEEDED). C IF (INIT) CALL I0TK00(INIT, 500, 4) C C C I1MACH(4) IS THE STANDARD ERROR MESSAGE WRITE UNIT. C ERROUT = I1MACH(4) WRITE (ERROUT, 9901) 9901 FORMAT (11H1STACK DUMP) C C C FIND THE MACHINE-DEPENDENT FORMATS FOR PRINTING - BUT ADD 1 TO C THE WIDTH TO GET SEPARATION BETWEEN ITEMS, AND SUBTRACT 1 FROM C THE NUMBER OF DIGITS AFTER THE DECIMAL POINT TO ALLOW FOR THE C 1P IN THE DUMP FORMAT OF 1PEW.D C C (NOTE, THAT ALTHOUGH IT IS NOT NECESSARY, 2 HAS BEEN ADDED TO C THE INTEGER WIDTH, WI, TO CONFORM WITH DAN WARNERS PREVIOUS C USAGE - SO PEOPLE CAN COMPARE DUMPS WITH ONES THEY HAVE HAD C AROUND FOR A LONG TIME.) C CALL FRMATR(WR,DR) CALL FRMATD(WD,DD) CALL FRMATI(WI) C WR = WR+1 WD = WD+1 WI = WI+2 DR = DR-1 DD = DD-1 C C CHECK, IN VARIOUS WAYS, THE BOOKKEEPING PART OF THE STACK TO SEE C IF THINGS WERE OVERWRITTEN. C C LOUT IS THE NUMBER OF CURRENT ALLOCATIONS C LNOW IS THE CURRENT ACTIVE LENGTH OF THE STACK C LUSED IS THE MAXIMUM VALUE OF LNOW ACHIEVED C LMAX IS THE MAXIMUM LENGTH OF THE STACK C LBOOK IS THE NUMBER OF WORDS USED FOR BOOK-KEEPING C TRBL1 = LBOOK .NE. 10 IF (.NOT. TRBL1) TRBL1 = LMAX .LT. 12 IF (.NOT. TRBL1) TRBL1 = LMAX .LT. LUSED IF (.NOT. TRBL1) TRBL1 = LUSED .LT. LNOW IF (.NOT. TRBL1) TRBL1 = LNOW .LT. LBOOK IF (.NOT. TRBL1) TRBL1 = LOUT .LT. 0 IF (.NOT. TRBL1) GO TO 10 C WRITE (ERROUT, 9902) 9902 FORMAT (29H0STACK HEADING IS OVERWRITTEN) WRITE (ERROUT, 9903) 9903 FORMAT (47H UNSTRUCTURED DUMP OF THE DEFAULT STACK FOLLOWS) C C SINCE INFORMATION IS LOST, SIMPLY SET THE USUAL DEFAULT VALUES FOR C THE LENGTH OF THE ENTIRE STACK IN TERMS OF EACH (LOGICAL, INTEGER, C ETC.,) TYPE. C LNG(1) = 1000 LNG(2) = 1000 LNG(3) = 1000 LNG(4) = 500 LNG(5) = 500 C C CALL U9DMP(LNG, MCOL, WI, WR, DR, WD, DD) GO TO 110 C C WRITE OUT THE STORAGE UNITS USED BY EACH TYPE OF VARIABLE C 10 WRITE (ERROUT, 9904) 9904 FORMAT (19H0STORAGE PARAMETERS) WRITE (ERROUT, 9905) ISIZE(1) 9905 FORMAT (18H LOGICAL , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9906) ISIZE(2) 9906 FORMAT (18H INTEGER , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9907) ISIZE(3) 9907 FORMAT (18H REAL , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9908) ISIZE(4) 9908 FORMAT (18H DOUBLE PRECISION , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9909) ISIZE(5) 9909 FORMAT (18H COMPLEX , I7, 14H STORAGE UNITS) C C WRITE OUT THE CURRENT STACK STATISTICS (I.E. USAGE) C WRITE (ERROUT, 9910) 9910 FORMAT (17H0STACK STATISTICS) WRITE (ERROUT, 9911) LMAX 9911 FORMAT (23H STACK SIZE , I7) WRITE (ERROUT, 9912) LUSED 9912 FORMAT (23H MAXIMUM STACK USED , I7) WRITE (ERROUT, 9913) LNOW 9913 FORMAT (23H CURRENT STACK USED , I7) WRITE (ERROUT, 9914) LOUT 9914 FORMAT (23H NUMBER OF ALLOCATIONS , I7) C C HERE AT LEAST THE BOOKKEEPING PART OF THE STACK HAS NOT BEEN C OVERWRITTEN. C C STACKDUMP WORKS BACKWARDS FROM THE END (MOST RECENT ALLOCATION) OF C THE STACK, PRINTING INFORMATION, BUT ALWAYS CHECKING TO SEE IF C THE POINTERS FOR AN ALLOCATION HAVE BEEN OVERWRITTEN. C C LLOUT COUNTS THE NUMBER OF ALLOCATIONS STILL LEFT TO PRINT C SO LLOUT IS INITIALLY LOUT OR ISTAK(1). C C THE STACK ALLOCATION ROUTINE PUTS, AT THE END OF EACH ALLOCATION, C TWO EXTRA SPACES - ONE FOR THE TYPE OF THE ALLOCATION AND THE NEXT C TO HOLD A BACK POINTER TO THE PREVIOUS ALLOCATION. C THE BACK POINTER IS THEREFORE INITIALLY LOCATED AT THE INITIAL END, C LNOW, OF THE STACK. C CALL THIS LOCATION BPNTR. C LLOUT = LOUT BPNTR = LNOW C C IF WE ARE DONE, THE BACK POINTER POINTS BACK INTO THE BOOKKEEPING C PART OF THE STACK. C C IF WE ARE NOT DONE, OBTAIN THE NEXT REGION TO PRINT AND GET ITS TYPE. C 20 IF (BPNTR .LE. LBOOK) GO TO 110 C LNEXT = ISTAK(BPNTR) ITYPE = ISTAK(BPNTR-1) C C SEE IF ANY OF THESE NEW DATA ARE INCONSISTENT - WHICH WOULD SIGNAL C AN OVERWRITE. C TRBL2 = LNEXT .LT. LBOOK IF (.NOT. TRBL2) TRBL2 = BPNTR .LE. LNEXT IF (.NOT. TRBL2) TRBL2 = ITYPE .LT. 0 IF (.NOT. TRBL2) TRBL2 = 5 .LT. ITYPE IF (.NOT. TRBL2) GO TO 40 C C HERE THERE SEEMS TO HAVE BEEN A PARTIAL OVERWRITE. C COMPUTE THE LENGTH OF THE ENTIRE STACK IN TERMS OF THE VALUES GIVEN C IN THE BOOKKEEPING PART OF THE STACK (WHICH, AT LEAST, SEEMS NOT TO C HAVE BEEN OVERWRITTEN), AND DO AN UNFORMATTED DUMP, AND RETURN. C WRITE (ERROUT, 9915) 9915 FORMAT (28H0STACK PARTIALLY OVERWRITTEN) WRITE (ERROUT, 9916) 9916 FORMAT (45H UNSTRUCTURED DUMP OF REMAINING STACK FOLLOWS) C DO 30 I = 1, 5 LNG(I) = (BPNTR*ISIZE(2)-1)/ISIZE(I)+1 30 CONTINUE C CALL U9DMP(LNG, MCOL, WI, WR, DR, WD, DD) GO TO 110 C C C COMES HERE EACH TIME TO PRINT NEXT (BACK) ALLOCATION. C C AT THIS POINT BPNTR POINTS TO THE END OF THE ALLOCATION ABOUT TO C BE PRINTED, LNEXT = ISTAK(BPNTR) POINTS BACK TO THE END OF THE C PREVIOUS ALLOCATION, AND ITYPE = ISTAK(BPNTR-1) GIVES THE TYPE OF C THE ALLOCATION ABOUT TO BE PRINTED. C C THE PRINTING ROUTINES NEED TO KNOW THE START OF THE ALLOCATION AND C THE NUMBER OF ITEMS. C THESE ARE COMPUTED FROM THE EQUATIONS USED WHEN THE FUNCTION ISTKGT C COMPUTED THE ORIGINAL ALLOCATION - THE POINTER TO THE C START OF THE ALLOCATION WAS COMPUTED BY ISTKGT FROM THE (THEN) C END OF THE PREVIOUS ALLOCATION VIA THE FORMULA, C C ISTKGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2 C 40 IPTR = (LNEXT*ISIZE(2)-1)/ISIZE(ITYPE) + 2 C C THE FUNCTION ISTKGT THEN FOUND NEW END OF THE STACK, LNOW, FROM THE C FORMULA C C I = ( (ISTKGT-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3 C C HERE WE SOLVE THIS FOR NITEMS TO DETERMINE THE NUMBER OF LOCATIONS C IN THIS ALLOCATION. C NITEMS = 1-IPTR + ((BPNTR-3)*ISIZE(2)+1)/ISIZE(ITYPE) C C C USE THE TYPE (INTEGER, REAL, ETC.) TO DTERMINE WHICH PRINTING C ROUTINE TO USE. C IF (ITYPE .EQ. 1) GO TO 50 IF (ITYPE .EQ. 2) GO TO 60 IF (ITYPE .EQ. 3) GO TO 70 IF (ITYPE .EQ. 4) GO TO 80 IF (ITYPE .EQ. 5) GO TO 90 C 50 WRITE (ERROUT, 9917) LLOUT, IPTR 9917 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 23H, TYPE LOGICAL) CALL A9RNTL(LSTAK(IPTR), NITEMS, ERROUT, MCOL) GO TO 100 C 60 WRITE (ERROUT, 9918) LLOUT, IPTR 9918 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 23H, TYPE INTEGER) CALL A9RNTI(ISTAK(IPTR), NITEMS, ERROUT, MCOL, WI) GO TO 100 C 70 WRITE (ERROUT, 9919) LLOUT, IPTR 9919 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 20H, TYPE REAL) CALL A9RNTR(RSTAK(IPTR), NITEMS, ERROUT, MCOL, WR, DR) GO TO 100 C 80 WRITE (ERROUT, 9920) LLOUT, IPTR 9920 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 32H, TYPE DOUBLE PRECISION) CALL A9RNTD(DSTAK(IPTR), NITEMS, ERROUT, MCOL, WD, DD) GO TO 100 C 90 WRITE (ERROUT, 9921) LLOUT, IPTR 9921 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 23H, TYPE COMPLEX) C/R C CALL A9RNTC(CMSTAK(1,IPTR), NITEMS, ERROUT, MCOL, WR,DR) C/C CALL A9RNTC(CMSTAK(IPTR), NITEMS, ERROUT, MCOL, WR, DR) C/ C 100 BPNTR = LNEXT LLOUT = LLOUT-1 GO TO 20 C 110 WRITE (ERROUT, 9922) 9922 FORMAT (18H0END OF STACK DUMP) RETURN END LOGICAL FUNCTION STOPX(IDUMMY) C *****PARAMETERS... INTEGER IDUMMY C C .................................................................. C C *****PURPOSE... C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A C DYNAMIC STOPX. C C *****ALGORITHM NOTES... C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. C C .................................................................. C STOPX = .FALSE. RETURN END SUBROUTINE U9DMP(LNG, NCOL, WI, WR, DR, WD, DD) C C THIS SUBROUTINE ASSUMES THAT THE TYPE (INTEGER, ETC.) OF THE DATA C IN THE PORT STACK IS NOT KNOWN - SO IT PRINTS OUT, IN ALL FORMATS C THE STACK CONTENTS, USING THE ARRAY OUTPUT ROUTINES APRNTX. C C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, NOVEMBER 8, 1982. C C INPUT PARAMETERS - C C LNG - AN INTEGER VECTOR ARRAY CONTAINING IN C LNG(1) THE LENGTH OF THE ARRAY IF LOGICAL C LNG(2) THE LENGTH OF THE ARRAY IF INTEGER C LNG(3) THE LENGTH OF THE ARRAY IF REAL C LNG(4) THE LENGTH OF THE ARRAY IF DOUBLE PRECISION C LNG(5) THE LENGTH OF THE ARRAY IF COMPLEX C C NCOL - THE NUMBER OF SPACES ACROSS A PRINTED LINE C C WI - THE FORMAT WIDTH FOR AN INTEGER C C WR - THE FORMAT WIDTH FOR A REAL (W IN 1PEW.D) C C DR - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT C (THE D IN THE 1PEW.D FORMULA) C C WD - THE FORMAT WIDTH FOR A REAL (W IN 1PDW.D) C C DD - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT C (THE D IN THE 1PDW.D FORMULA) C C C ERROR STATES - NONE. U9DMP IS CALLED BY SETERR, C SO IT CANNOT CALL SETERR. C C INTEGER LNG(5), NCOL, WI, WR, DR, WD INTEGER DD COMMON /CSTAK/ DSTAK DOUBLE PRECISION DSTAK(500) INTEGER ERROUT, ISTAK(1000), I1MACH REAL RSTAK(1000) LOGICAL LSTAK(1000) C/R C REAL CMSTAK(2,500) C EQUIVALENCE (DSTAK(1), CMSTAK(1,1)) C/C COMPLEX CMSTAK(500) EQUIVALENCE (DSTAK(1), CMSTAK(1)) C/ EQUIVALENCE (DSTAK(1), ISTAK(1)) EQUIVALENCE (DSTAK(1), LSTAK(1)) EQUIVALENCE (DSTAK(1), RSTAK(1)) C ERROUT = I1MACH(4) C WRITE (ERROUT, 1) 1 FORMAT (14H0LOGICAL STACK) CALL A9RNTL(LSTAK, LNG(1), ERROUT, NCOL) WRITE (ERROUT, 2) 2 FORMAT (14H0INTEGER STACK) CALL A9RNTI(ISTAK, LNG(2), ERROUT, NCOL, WI) WRITE (ERROUT, 3) 3 FORMAT (11H0REAL STACK) CALL A9RNTR(RSTAK, LNG(3), ERROUT, NCOL, WR, DR) WRITE (ERROUT, 4) 4 FORMAT (23H0DOUBLE PRECISION STACK) CALL A9RNTD(DSTAK, LNG(4), ERROUT, NCOL, WD, DD) WRITE (ERROUT, 5) 5 FORMAT (14H0COMPLEX STACK) CALL A9RNTC(CMSTAK, LNG(5), ERROUT, NCOL, WR, DR) C RETURN END SUBROUTINE V2AXY(P, W, A, X, Y) C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C INTEGER P REAL A, W(P), X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END REAL FUNCTION V2NRM(P, X) C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C INTEGER P REAL X(P) C INTEGER I, J REAL ONE, R, SCALE, SQTETA, T, XI, ZERO C/+ REAL SQRT C/ REAL R7MDC EXTERNAL R7MDC C C/6 C DATA ONE/1.E+0/, ZERO/0.E+0/ C/7 PARAMETER (ONE=1.E+0, ZERO=0.E+0) SAVE SQTETA C/ DATA SQTETA/0.E+0/ C IF (P .GT. 0) GO TO 10 V2NRM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE V2NRM = ZERO GO TO 999 C 30 SCALE = ABS(X(I)) IF (I .LT. P) GO TO 40 V2NRM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = R7MDC(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = ABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C V2NRM = SCALE * SQRT(T) 999 RETURN C *** LAST LINE OF V2NRM FOLLOWS *** END SUBROUTINE V7CPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C INTEGER P REAL X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) RETURN END SUBROUTINE V7DFL(ALG, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER ALG, LV REAL V(LV) C REAL R7MDC EXTERNAL R7MDC C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS C REAL MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR V *** C INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC, 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ, HUBERC, 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX, 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2, 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL C C/6 C DATA ONE/1.E+0/, THREE/3.E+0/ C/7 PARAMETER (ONE=1.E+0, THREE=3.E+0) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA AFCTOL/31/, BIAS/43/, COSMIN/47/, DECFAC/22/, DELTA0/44/, C 1 DFAC/41/, DINIT/38/, DLTFDC/42/, DLTFDJ/43/, DTINIT/39/, C 2 D0INIT/40/, EPSLON/19/, ETA0/42/, FUZZ/45/, HUBERC/48/, C 3 INCFAC/23/, LMAX0/35/, LMAXS/36/, PHMNFC/20/, PHMXFC/21/, C 4 RDFCMN/24/, RDFCMX/25/, RFCTOL/32/, RLIMIT/46/, RSPTOL/49/, C 5 SCTOL/37/, SIGMIN/50/, TUNER1/26/, TUNER2/27/, TUNER3/28/, C 6 TUNER4/29/, TUNER5/30/, XCTOL/33/, XFTOL/34/ C/7 PARAMETER (AFCTOL=31, BIAS=43, COSMIN=47, DECFAC=22, DELTA0=44, 1 DFAC=41, DINIT=38, DLTFDC=42, DLTFDJ=43, DTINIT=39, 2 D0INIT=40, EPSLON=19, ETA0=42, FUZZ=45, HUBERC=48, 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21, 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49, 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28, 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34) C/ C C------------------------------- BODY -------------------------------- C MACHEP = R7MDC(3) V(AFCTOL) = 1.E-20 IF (MACHEP .GT. 1.E-10) V(AFCTOL) = MACHEP**2 V(DECFAC) = 0.5E+0 SQTEPS = R7MDC(4) V(DFAC) = 0.6E+0 V(DTINIT) = 1.E-6 MEPCRT = MACHEP ** (ONE/THREE) V(D0INIT) = 1.E+0 V(EPSLON) = 0.1E+0 V(INCFAC) = 2.E+0 V(LMAX0) = 1.E+0 V(LMAXS) = 1.E+0 V(PHMNFC) = -0.1E+0 V(PHMXFC) = 0.1E+0 V(RDFCMN) = 0.1E+0 V(RDFCMX) = 4.E+0 V(RFCTOL) = AMAX1(1.E-10, MEPCRT**2) V(SCTOL) = V(RFCTOL) V(TUNER1) = 0.1E+0 V(TUNER2) = 1.E-4 V(TUNER3) = 0.75E+0 V(TUNER4) = 0.5E+0 V(TUNER5) = 0.75E+0 V(XCTOL) = SQTEPS V(XFTOL) = 1.E+2 * MACHEP C IF (ALG .GE. 2) GO TO 10 C C *** REGRESSION VALUES C V(COSMIN) = AMAX1(1.E-6, 1.E+2 * MACHEP) V(DINIT) = 0.E+0 V(DELTA0) = SQTEPS V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(FUZZ) = 1.5E+0 V(HUBERC) = 0.7E+0 V(RLIMIT) = R7MDC(5) V(RSPTOL) = 1.E-3 V(SIGMIN) = 1.E-4 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 V(BIAS) = 0.8E+0 V(DINIT) = -1.0E+0 V(ETA0) = 1.0E+3 * MACHEP C 999 RETURN C *** LAST CARD OF V7DFL FOLLOWS *** END SUBROUTINE V7IPR(N, IP, X) C C PERMUTE X SO THAT X.OUTPUT(I) = X.INPUT(IP(I)). C IP IS UNCHANGED ON OUTPUT. C INTEGER N INTEGER IP(N) REAL X(N) C INTEGER I, J, K REAL T DO 30 I = 1, N J = IP(I) IF (J .EQ. I) GO TO 30 IF (J .GT. 0) GO TO 10 IP(I) = -J GO TO 30 10 T = X(I) K = I 20 X(K) = X(J) K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 20 X(K) = T 30 CONTINUE 999 RETURN C *** LAST LINE OF V7IPR FOLLOWS *** END SUBROUTINE V7PRM(N, IP, X) C C PERMUTE X SO THAT X.OUTPUT(IP(I)) = X.INPUT(I). C IP IS UNCHANGED ON OUTPUT. C INTEGER N INTEGER IP(N) REAL X(N) C INTEGER I, J, K REAL S, T DO 30 I = 1, N J = IP(I) IF (J .EQ. I) GO TO 30 IF (J .GT. 0) GO TO 10 IP(I) = -J GO TO 30 10 T = X(I) 20 S = X(J) X(J) = T T = S K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 20 X(J) = T 30 CONTINUE 999 RETURN C *** LAST LINE OF V7PRM FOLLOWS *** END SUBROUTINE V7SCL(N, X, A, Y) C C *** SET X(I) = A*Y(I), I = 1(1)N *** C INTEGER N REAL A, X(N), Y(N) C INTEGER I C DO 10 I = 1, N 10 X(I) = A * Y(I) 999 RETURN C *** LAST LINE OF V7SCL FOLLOWS *** END SUBROUTINE V7SCP(P, Y, S) C C *** SET P-VECTOR Y TO SCALAR S *** C INTEGER P REAL S, Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = S RETURN END SUBROUTINE V7SHF(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION *** C INTEGER N, K REAL X(N) C INTEGER I, NM1 REAL T C IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T 999 RETURN END SUBROUTINE V7SWP(N, X, Y) C C *** INTERCHANGE N-VECTORS X AND Y. *** C INTEGER N REAL X(N), Y(N) C INTEGER I REAL T C DO 10 I = 1, N T = X(I) X(I) = Y(I) Y(I) = T 10 CONTINUE 999 RETURN C *** LAST CARD OF V7SWP FOLLOWS *** END SUBROUTINE V7VMP(N, X, Y, Z, K) C C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) *** C INTEGER N, K REAL X(N), Y(N), Z(N) INTEGER I C IF (K .GE. 0) GO TO 20 DO 10 I = 1, N 10 X(I) = Y(I) / Z(I) GO TO 999 C 20 DO 30 I = 1, N 30 X(I) = Y(I) * Z(I) 999 RETURN C *** LAST CARD OF V7VMP FOLLOWS *** END SUBROUTINE W7ZBF (L, N, S, W, Y, Z) C C *** COMPUTE Y AND Z FOR L7UPD CORRESPONDING TO BFGS UPDATE. C INTEGER N REAL L(1), S(N), W(N), Y(N), Z(N) C DIMENSION L(N*(N+1)/2) C C-------------------------- PARAMETER USAGE -------------------------- C C L (I/O) CHOLESKY FACTOR OF HESSIAN, A LOWER TRIANG. MATRIX STORED C COMPACTLY BY ROWS. C N (INPUT) ORDER OF L AND LENGTH OF S, W, Y, Z. C S (INPUT) THE STEP JUST TAKEN. C W (OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 CORRECTION TO L. C Y (INPUT) CHANGE IN GRADIENTS CORRESPONDING TO S. C Z (OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 CORRECTION TO L. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C WHEN S IS COMPUTED IN CERTAIN WAYS, E.G. BY GQTSTP OR C DBLDOG, IT IS POSSIBLE TO SAVE N**2/2 OPERATIONS SINCE (L**T)*S C OR L*(L**T)*S IS THEN KNOWN. C IF THE BFGS UPDATE TO L*(L**T) WOULD REDUCE ITS DETERMINANT TO C LESS THAN EPS TIMES ITS OLD VALUE, THEN THIS ROUTINE IN EFFECT C REPLACES Y BY THETA*Y + (1 - THETA)*L*(L**T)*S, WHERE THETA C (BETWEEN 0 AND 1) IS CHOSEN TO MAKE THE REDUCTION FACTOR = EPS. C C *** GENERAL *** C C CODED BY DAVID M. GAY (FALL 1979). C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** FUNCTIONS AND SUBROUTINES CALLED *** C REAL D7TPR EXTERNAL D7TPR, L7IVM, L7TVM C D7TPR RETURNS INNER PRODUCT OF TWO VECTORS. C L7IVM MULTIPLIES L**-1 TIMES A VECTOR. C L7TVM MULTIPLIES L**T TIMES A VECTOR. C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C-------------------------- LOCAL VARIABLES -------------------------- C INTEGER I REAL CS, CY, EPS, EPSRT, ONE, SHS, YS, THETA C C *** DATA INITIALIZATIONS *** C C/6 C DATA EPS/0.1E+0/, ONE/1.E+0/ C/7 PARAMETER (EPS=0.1E+0, ONE=1.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C CALL L7TVM(N, W, L, S) SHS = D7TPR(N, W, W) YS = D7TPR(N, Y, S) IF (YS .GE. EPS*SHS) GO TO 10 THETA = (ONE - EPS) * SHS / (SHS - YS) EPSRT = SQRT(EPS) CY = THETA / (SHS * EPSRT) CS = (ONE + (THETA-ONE)/EPSRT) / SHS GO TO 20 10 CY = ONE / ( SQRT(YS) * SQRT(SHS)) CS = ONE / SHS 20 CALL L7IVM(N, Z, L, Y) DO 30 I = 1, N 30 Z(I) = CY * Z(I) - CS * W(I) C 999 RETURN C *** LAST CARD OF W7ZBF FOLLOWS *** END SUBROUTINE XTRAP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST) C C ASSUME AN EXPANSION FOR THE VECTOR VALUED FUNCTION T(H) OF THE FORM C C T(H) = T(0) + SUM(J=1,2,3,...)(A(J)*H**(J*GAMMA)) C C WHERE THE A(J) ARE CONSTANT VECTORS AND GAMMA IS A POSITIVE CONSTANT. C C GIVEN T(H(M)), WHERE H(M)=H0/N(M), M=1,2,3,..., THIS ROUTINE USES C POLYNOMIAL (XPOLY), OR RATIONAL (.NOT.XPOLY), EXTRAPOLATION TO C SEQUENTIALLY APPROXIMATE T(0). C C INPUT C C TM - TM = T(H(M)) FOR THIS CALL. C M - H(M) WAS USED TO OBTAIN TM. C NVAR - THE LENGTH OF THE VECTOR TM. C NG - THE REAL VALUES C C NG(I) = N(I)**GAMMA C C FOR I=1,...,M. NG MUST BE A MONOTONE INCREASING ARRAY. C KMAX - THE MAXIMUM NUMBER OF COLUMNS TO BE USED IN THE C EXTRAPOLATION PROCESS. C XPOLY - IF XPOLY=.TRUE., THEN USE POLYNOMIAL EXTRAPOLATION. C IF XPOLY=.FALSE., THEN USE RATIONAL EXTRAPOLATION. C T - THE BOTTOM EDGE OF THE EXTRAPOLATION LOZENGE. C T(I,J) SHOULD CONTAIN THE J-TH EXTRAPOLATE OF THE I-TH C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M-1), C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX). C C WHEN M=1, T MAY CONTAIN ANYTHING. C C FOR M.GT.1, NOTE THAT THE OUTPUT VALUE OF T AT THE C (M-1)-ST CALL IS THE INPUT FOR THE M-TH CALL. C THUS, THE USER NEED NEVER PUT ANYTHING INTO T, C BUT HE CAN NOT ALTER ANY ELEMENT OF T BETWEEN C CALLS TO XTRAP. C C OUTPUT C C TM - TM(I)=THE MOST ACCURATE APPROXIMATION IN THE LOZENGE C FOR THE I-TH VARIABLE, I=1,...,NVAR. C T - T(I,J) CONTAINS THE J-TH EXTRAPOLATE OF THE I-TH C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M), C FOR I=1,...,NVAR AND J=1,...,MIN(M,KMAX). C ERROR - ERROR(I,J) GIVES THE SIGNED BULIRSCH-STOER ESTIMATE OF THE C ERROR IN THE J-TH EXTRAPOLATE OF THE I-TH COMPONENT OF C T(H) BASED ON THE SEQUENCE H(1),...,H(M-1), C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX). C IF ERROR=EBEST AS ARRAYS, THEN THE ABOVE ELEMENTS C ARE NOT STORED. RATHER, EBEST=ERROR IS LOADED AS DESCRIBED C BELOW. C EBEST - EBEST(I)=THE ABSOLUTE VALUE OF THE ERROR IN TM(I), C I=1,...,NVAR. THIS ARRAY IS FULL OF GARBAGE WHEN M=1. C C SCRATCH SPACE ALLOCATED - MIN(M-1,KMAX) REAL WORDS + C C MIN(M-1,KMAX) INTEGER WORDS. C C ERROR STATES - C C 1 - M.LT.1. C 2 - NVAR.LT.1. C 3 - NG(1).LT.1. C 4 - KMAX.LT.1. C 5 - NG IS NOT MONOTONE INCREASING. C REAL TM(NVAR),NG(M),T(NVAR,1) C REAL T(NVAR,MIN(M,KMAX)) REAL ERROR(NVAR,1),EBEST(NVAR) C REAL ERROR(NVAR,MIN(M-1,KMAX)) LOGICAL XPOLY C LOGICAL ESAVE C COMMON /CSTAK/DS DOUBLE PRECISION DS(500) REAL WS(1) REAL RS(1000) EQUIVALENCE (DS(1),WS(1)),(DS(1),RS(1)) C C ... CHECK THE INPUT. C C/6S C IF (M.LT.1) CALL SETERR(15H XTRAP - M.LT.1,15,1,2) C IF (NVAR.LT.1) CALL SETERR(18H XTRAP - NVAR.LT.1,18,2,2) C IF (NG(1).LT.1.0E0) CALL SETERR(19H XTRAP - NG(1).LT.1,19,3,2) C IF (KMAX.LT.1) CALL SETERR(18H XTRAP - KMAX.LT.1,18,4,2) C/7S IF (M.LT.1) CALL SETERR(' XTRAP - M.LT.1',15,1,2) IF (NVAR.LT.1) CALL SETERR(' XTRAP - NVAR.LT.1',18,2,2) IF (NG(1).LT.1.0E0) CALL SETERR(' XTRAP - NG(1).LT.1',19,3,2) IF (KMAX.LT.1) CALL SETERR(' XTRAP - KMAX.LT.1',18,4,2) C/ C IF (M.EQ.1) GO TO 20 C DO 10 I=2,M C/6S C IF (NG(I-1).GE.NG(I)) CALL SETERR C 1 (38H XTRAP - NG IS NOT MONOTONE INCREASING,38,5,2) C/7S IF (NG(I-1).GE.NG(I)) CALL SETERR 1 (' XTRAP - NG IS NOT MONOTONE INCREASING',38,5,2) C/ 10 CONTINUE C C ... SEE IF ERROR=EBEST AS ARRAYS. IF (ESAVE), THEN LOAD ERROR. C 20 ERROR(1,1)=1.0E0 EBEST(1)=2.0E0 ESAVE=ERROR(1,1).NE.EBEST(1) C C ... ALLOCATE SCRATCH SPACE. C IRHG=1 IEMAG=1 IF (M.GT.1) IRHG=ISTKGT(MIN0(M-1,KMAX),3) IF (M.GT.1) IEMAG=ISTKGT(MIN0(M-1,KMAX),3) C CALL A0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,WS(IRHG), 1 RS(IEMAG),ESAVE) C IF (M.GT.1) CALL ISTKRL(2) C RETURN C END REAL FUNCTION ZERO(F,A,B,T) C C FINDS THE REAL ROOT OF THE FUNCTION F LYING BETWEEN A AND B C TO WITHIN A TOLERANCE OF C C 6*R1MACH(3) * ABS(ZERO) + 2 * T C C F(A) AND F(B) MUST HAVE OPPOSITE SIGNS C C THIS IS BRENTS ALGORITHM C C A, STORED IN SA, IS THE PREVIOUS BEST APPROXIMATION (I.E. THE OLD B) C B, STORED IN SB, IS THE CURRENT BEST APPROXIMATION C C IS THE MOST RECENTLY COMPUTED POINT SATISFYING F(B)*F(C) .LT. 0 C D CONTAINS THE CORRECTION TO THE APPROXIMATION C E CONTAINS THE PREVIOUS VALUE OF D C M CONTAINS THE BISECTION QUANTITY (C-B)/2 C REAL A,B,T,TT,SA,SB,C,D,E,FA,FB,FC,TOL,M,P,Q,R,S EXTERNAL F C TT = T IF (T .LE. 0.0) TT = 10.*R1MACH(1) C SA = A SB = B FA = F(SA) FB = F(SB) IF (FA .NE. 0.0) GO TO 5 ZERO = SA RETURN 5 IF (FB .EQ. 0.0) GO TO 140 C/6S C IF (SIGN(FA,FB) .EQ. FA) CALL SETERR( C 1 46H ZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN, 46, 1, 1) C/7S IF (SIGN(FA,FB) .EQ. FA) CALL SETERR( 1 ' ZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN', 46, 1, 1) C/ C 10 C = SA FC = FA E = SB-SA D = E C C INTERCHANGE B AND C IF ABS F(C) .LT. ABS F(B) C 20 IF (ABS(FC).GE.ABS(FB)) GO TO 30 SA = SB SB = C C = SA FA = FB FB = FC FC = FA C 30 TOL = 2.0*R1MACH(4)*ABS(SB)+TT M = 0.5*(C-SB) C C SUCCESS INDICATED BY M REDUCES TO UNDER TOLERANCE OR C BY F(B) = 0 C IF ((ABS(M).LE.TOL).OR.(FB.EQ.0.0)) GO TO 140 C C A BISECTION IS FORCED IF E, THE NEXT-TO-LAST CORRECTION C WAS LESS THAN THE TOLERANCE OR IF THE PREVIOUS B GAVE C A SMALLER F(B). OTHERWISE GO TO 40. C IF ((ABS(E).GE.TOL).AND.(ABS(FA).GE.ABS(FB))) GO TO 40 E = M D = E GO TO 100 40 S = FB/FA C C QUADRATIC INTERPOLATION CAN ONLY BE DONE IF A (IN SA) C AND C ARE DIFFERENT POINTS. C OTHERWISE DO THE FOLLOWING LINEAR INTERPOLATION C IF (SA.NE.C) GO TO 50 P = 2.0*M*S Q = 1.0-S GO TO 60 C C INVERSE QUADRATIC INTERPOLATION C 50 Q = FA/FC R = FB/FC P = S*(2.0*M*Q*(Q-R)-(SB-SA)*(R-1.0)) Q = (Q-1.0)*(R-1.0)*(S-1.0) 60 IF (P.LE.0.0) GO TO 70 Q = -Q GO TO 80 70 P = -P C C UPDATE THE QUANTITIES USING THE NEWLY COMPUTED C INTERPOLATE UNLESS IT WOULD EITHER FORCE THE C NEW POINT TOO FAR TO ONE SIDE OF THE INTERVAL C OR WOULD REPRESENT A CORRECTION GREATER THAN C HALF THE PREVIOUS CORRECTION. C C IN THESE LAST TWO CASES - DO THE BISECTION C BELOW (FROM STATEMENT 90 TO 100) C 80 S = E E = D IF ((2.0*P.GE.3.0*M*Q-ABS(TOL*Q)).OR. 1 (P.GE.ABS(0.5*S*Q))) GO TO 90 D = P/Q GO TO 100 90 E = M D = E C C SET A TO THE PREVIOUS B C 100 SA = SB FA = FB C C IF THE CORRECTION TO BE MADE IS SMALLER THAN C THE TOLERANCE, JUST TAKE A DELTA STEP (DELTA=TOLERANCE) C B = B + DELTA * SIGN(M) C IF (ABS(D).LE.TOL) GO TO 110 SB = SB+D GO TO 130 C 110 IF (M.LE.0.0) GO TO 120 SB = SB+TOL GO TO 130 C 120 SB = SB-TOL 130 FB = F(SB) C C IF F(B) AND F(C) HAVE THE SAME SIGN ONLY C LINEAR INTERPOLATION (NOT INVERSE QUADRATIC) C CAN BE DONE C IF ((FB.GT.0.0).AND.(FC.GT.0.0)) GO TO 10 IF ((FB.LE.0.0).AND.(FC.LE.0.0)) GO TO 10 GO TO 20 C C***SUCCESS*** 140 ZERO = SB RETURN END SUBROUTINE SROTG () RETURN END SUBROUTINE SROT () RETURN END SUBROUTINE SROT2 () RETURN END SUBROUTINE DS4ROT () RETURN END SUBROUTINE L9STP () RETURN END