C Dummy for R LOGICAL FUNCTION STOPX() STOPX = .FALSE. END C Minimally modernized in 2018-09, so is fixed-form F90, not F77 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 PARAMETER (HALF=0.5D+0, ZERO=0.D+0) C C *** IV SUBSCRIPT VALUES *** C 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 *** V SUBSCRIPT VALUES *** C PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) 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 c IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I IF (IV(TOOBIG) .EQ. 0) THEN select case(I) case(1,3,6) goto 150 case(2) goto 130 case(4,5) goto 120 end select END IF 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) .EQ. 2) GO TO 60 IF (IV(1) .GT. 2) GO TO 220 C 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 290 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 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(*), L(*) 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 RETURN 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, 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 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 *** V SUBSCRIPT VALUES *** C 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 PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0) 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) THEN c GO TO (250,250,250,250,250,250,190,150,190, 20,20,30), I select case(I) case(1:6) goto 250 case(7,9) goto 190 case(8) goto 150 case(10,11) goto 20 case(12) goto 30 end select END IF 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()) 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 c GO TO (300, 270, 280, 290), I select case(I) case(1) goto 300 case(2) goto 270 case(3) goto 280 case(4) goto 290 end select 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) c GO TO (310,340,340,340,310,320,330,330,330,330,330,330,410,380), K select case(K) case(1) goto 310 case(2:4) goto 340 case(5) goto 310 case(6) goto 320 case(7:12) goto 330 case(13) goto 410 case(14) goto 380 end select 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 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, 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 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 *** V SUBSCRIPT VALUES *** C 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 PARAMETER (ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0) 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) THEN c GO TO (220,220,220,220,220,220,160,120,160, 10,10,20), I select case(I) case(1:6) goto 220 case(7,9) goto 160 case(8) goto 120 case(10,11) goto 10 case(12) goto 20 end select END IF 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()) 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 c GO TO (270, 240, 250, 260), I select case(I) case(1) goto 270 case(2) goto 240 case(3) goto 250 case(4) goto 260 end select 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) c GO TO (280,310,310,310,280,290,300,300,300,300,300,300,380,350), K select case(K) case(1) goto 280 case(2:4) goto 310 case(5) goto 280 case(6) goto 290 case(7:12) goto 300 case(13) goto 380 case(14) goto 350 end select 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 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(*), W(P) C DIMENSION 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 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 PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30, 1 NITER=31, SGIRC=57, TOOBIG=2, VNEED=4) PARAMETER (ZERO=0.D+0) 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) .LT. 2) GO TO 999 IF (IV(1) .GT. 2) GO TO 70 C C *** COMPUTE GRADIENT *** C 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 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(*), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, II, IJ, I0, J, NP1 DOUBLE PRECISION T, ZERO PARAMETER (ZERO=0.D+0) 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 RETURN C *** LAST CARD OF DL7VML 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 PARAMETER (HALF=0.5D+0, ONE=1.D+0, ONEP2=1.2D+0, TWO=2.D+0, 1 ZERO=0.D+0) C 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) 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+++++++++++++++++++++++++++++++ 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) THEN c GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I select case(I) case(1) goto 20 case(2) goto 30 case(3,4) goto 10 case(5) goto 40 case(6) goto 280 case(7:11) goto 220 case(12) goto 170 end select END IF 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) c GO TO (20, 30, 110, 110, 70), I select case(I) case(1) goto 20 case(2) goto 30 case(3,4) goto 110 case(5) goto 70 end select 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 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 X(I) = X(I+1) 10 CONTINUE 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 SUBROUTINE S7ETR(M,N,NPAIRS,INDROW,JPNTR,INDCOL,IPNTR,IWA) INTEGER M,N,NPAIRS INTEGER INDROW(NPAIRS),JPNTR(N+1),INDCOL(NPAIRS),IPNTR(M+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 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(*), G(P), L(*), 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 PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) 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 RETURN C *** LAST LINE OF DG7QSB 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(*), 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 PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0) 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 + DBLE(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 + DBLE(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 X(I) = T*X(I) 50 CONTINUE 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 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 PARAMETER (DFAC=41, DTOL=59, DTYPE=16, NITER=31) 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 S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA) INTEGER N,NNZ INTEGER INDROW(NNZ),INDCOL(NNZ),JPNTR(N+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 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(*), A(*) 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/ PARAMETER (ZERO=0.D+0) 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(*), 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 PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0) 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 + DBLE(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 + DBLE(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 X(I) = T*X(I) 70 CONTINUE 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 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(*), 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 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 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(*), LIN(*) 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 PARAMETER (ONE=1.D+0, ZERO=0.D+0) 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 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 PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0) C 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+++++++++++++++++++++++++++++++ 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 STEP(I) = -NWTSTP(I) 20 CONTINUE 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 STEP(I) = T * NWTSTP(I) 40 CONTINUE 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 STEP(I) = T * DIG(I) 60 CONTINUE 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 STEP(I) = T1*DIG(I) + T2*NWTSTP(I) 80 CONTINUE C 999 RETURN C *** LAST LINE OF DD7DOG 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(*) 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 RETURN C *** LAST LINE OF DS7IPR 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 RETURN C *** LAST LINE OF DH2RFA FOLLOWS *** 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) CHARACTER(4) CNGD(3), DFLT(3), WHICH(3) 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 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 DATA BIG/0.D+0/, MACHEP/-1.D+0/, TINY/1.D+0/, ZERO/0.D+0/ 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 DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ 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 C IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV) C 10 FORMAT(/40H THE FIRST PARAMETER TO DIVSET SHOULD BE,I3, C 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 C WRITE(PU,40) VARNM(ALG1), N C 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 C WRITE(PU,70) VARNM(ALG1), IV(OLDN), N C 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 C IF (PU .NE. 0) WRITE(PU,90) IV1 C 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 C IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK, C 1 VM(I), VX(I) C 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,D11.3,7H SHOULD, C 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 C WRITE(PU,160) IV(NVDFLT), NDFALT C 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 C IF (PU .NE. 0) WRITE(PU,180) I, D(I) C 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 C WRITE(PU,220) SH(ALG1), IV(INITS) C 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =, C 1 I3) 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250 C IF (M .EQ. 0) WRITE(PU,260) WHICH M = 1 C WRITE(PU,240) IV(DTYPE) C 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 C IF (M .EQ. 0) WRITE(PU,260) WHICH C 260 FORMAT(/1H ,3A4,9HALUES..../) M = 1 C WRITE(PU,270) VN(1,I), VN(2,I), K, V(K) C 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 C WRITE(PU,310) LIV, MIV2 C 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 C IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV) C 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5) GO TO 999 C 340 IV(1) = 67 C IF (PU .NE. 0) WRITE(PU,350) ALG C 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4) GO TO 999 360 CONTINUE C 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1 C 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5, C 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 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, 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX, 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2, 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL C PARAMETER (ONE=1.D+0, THREE=3.D+0) C C *** V SUBSCRIPT VALUES *** C 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, 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------------------------------- BODY -------------------------------- C MACHEP = DR7MDC(3) if (MACHEP .GT. 1.D-10) then V(AFCTOL) = MACHEP**2 else V(AFCTOL) = 1.D-20 endif 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 .eq. 1) then C C *** REGRESSION VALUES (nls) 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(RLIMIT) = DR7MDC(5) V(RSPTOL) = 1.D-3 V(SIGMIN) = 1.D-4 else C C *** GENERAL OPTIMIZATION VALUES (nlminb) C V(BIAS) = 0.8D+0 V(DINIT) = -1.0D+0 V(ETA0) = 1.0D+3 * MACHEP C end if C *** LAST CARD OF DV7DFL FOLLOWS *** 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 c GO TO (10, 20, 30, 40, 50, 60), K select case(K) case(1) goto 10 case(2) goto 20 case(3) goto 30 case(4) goto 40 case(5) goto 50 case(6) goto 60 end select 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 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 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 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 *** V SUBSCRIPT VALUES *** C 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 PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, 1 ZERO=0.D+0) 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 c GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I select case(I) case(1:6) goto 360 case(7,9) goto 240 case(8) goto 190 case(10,11) goto 20 case(12) goto 30 end select 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()) 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 c GO TO (410, 380, 390, 400), I select case(I) case(1) goto 410 case(2) goto 380 case(3) goto 390 case(4) goto 400 end select 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) THEN c GO TO (440,450,460,460,460,460,460,460,570,510), L select case(L) case(1) goto 440 case(2) goto 450 case(3:8) goto 460 case(9) goto 570 case(10) goto 510 end select END IF 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) c GO TO (610, 620, 630), I select case(I) case(1) goto 610 case(2) goto 620 case(3) goto 630 end select 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 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 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) 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 .EQ. 2) GO TO 150 IF (IV1 .GT. 2) GO TO 230 C C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED *** C 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 * DBLE(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 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1)) 130 CONTINUE 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 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(*), 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 PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0) 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 W(I) = T * WCHMTD(I) 10 CONTINUE CALL DS7LVM(P, U, A, STEP) T = HALF * (SIZE * DD7TPR(P, STEP, U) - DD7TPR(P, STEP, Y)) DO 20 I = 1, P U(I) = T*W(I) + Y(I) - SIZE*U(I) 20 CONTINUE 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 RETURN C *** LAST CARD OF DS7LUP 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(*), STEP(P), V(21), W(*) 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 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 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 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 .EQ. 0) GO TO 20 IF (KA .GT. 0) GO TO 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 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 W(I) = G(I)/D(I) 100 CONTINUE 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 W(I) = ONE 120 CONTINUE 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 STEP(K) = STEP(K)/DFAC 250 CONTINUE 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 STEP(I) = STEP(I) / DSQRT(W(I)) 340 CONTINUE 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 STEP(I) = ZERO 400 CONTINUE 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 RETURN C C *** LAST CARD OF DL7MST 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 PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30, 1 NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4) PARAMETER (ZERO=0.D+0) 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) .LT. 2) GO TO 999 IF (IV(1) .GT. 2) GO TO 80 C C *** COMPUTE GRADIENT *** C 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 D7EGR(M,N,NPAIRS,INDROW,JPNTR,INDCOL,IPNTR,NDEG, * IWA,BWA) INTEGER M,N,NPAIRS INTEGER INDROW(NPAIRS),JPNTR(N+1),INDCOL(NPAIRS),IPNTR(M+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 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, 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 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 *** V SUBSCRIPT VALUES *** C 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 PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, 1 ZERO=0.D+0) 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 c GO TO (190, 190, 190, 190, 190, 190, 120, 90, 120, 10, 10, 20), I select case(I) case(1:6) goto 190 case(7,9) goto 120 case(8) goto 90 case(10,11) goto 10 case(12) goto 20 end select 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()) 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 c GO TO (240, 210, 220, 230), I select case(I) case(1) goto 240 case(2) goto 210 case(3) goto 220 case(4) goto 230 end select 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) c GO TO (250,280,280,280,250,260,270,270,270,270,270,270,330,300), K select case(K) case(1,5) goto 250 case(2:4) goto 280 case(6) goto 260 case(7:12) goto 270 case(13) goto 330 case(14) goto 300 end select 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 I7DO(M,N,NPAIRS,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA) INTEGER M,N,MAXCLQ,NPAIRS INTEGER INDROW(NPAIRS),JPNTR(N+1),INDCOL(NPAIRS),IPNTR(M+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 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 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 DOUBLE PRECISION X(*), Y(*), Z(N) 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 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 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 PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7, 1 RADIUS=8, STPPAR=5) SAVE MEPS2 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 W(I) = -STEP(I) * TD(I) 20 CONTINUE 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 TG(I) = T1 * TG(I) 90 CONTINUE 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) RETURN C *** LAST LINE OF DS7BQN 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 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 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 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 *** V SUBSCRIPT VALUES *** C 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 PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, 1 ZERO=0.D+0) 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 c GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I select case(I) case(1:6) goto 290 case(7,9) goto 170 case(8) goto 120 case(10,11) goto 10 case(12) goto 20 end select 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()) 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 c GO TO (340, 310, 320, 330), I select case(I) case(1) goto 340 case(2) goto 310 case(3) goto 320 case(4) goto 330 end select 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) THEN c GO TO (370,380,390,390,390,390,390,390,500,440), L select case(L) case(1) goto 370 case(2) goto 380 case(3:8) goto 390 case(9) goto 500 case(10) goto 440 end select END IF 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) c GO TO (540, 550, 580), I select case(I) case(1) goto 540 case(2) goto 550 case(3) goto 580 end select 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 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(*), QTR(P), RMAT(*), 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(*), 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 PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) 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 IPIV1(I) = I 50 CONTINUE 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 RETURN C *** LAST LINE OF DL7MSB 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 PARAMETER (F=10, H=56, MODE=35, RDREQ=57, STEP=40) PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0) 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 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 RETURN C *** LAST LINE OF DR7TVM 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(*), 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 SAVE BIGRT, TINY, TINYRT 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 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 PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0, 1 ZERO=0.D+0) C 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+++++++++++++++++++++++++++++++ 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 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 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) 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 .EQ. 2) GO TO 150 IF (IV1 .GT. 2) GO TO 230 C C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED *** C 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 * DBLE(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 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1)) 130 CONTINUE 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 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(*), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, IJ, I0, J DOUBLE PRECISION YI, ZERO PARAMETER (ZERO=0.D+0) 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 RETURN C *** LAST CARD OF DL7TVM 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(*), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 DOUBLE PRECISION XI, ZERO PARAMETER (ZERO=0.D+0) C DO 10 I = 1, N X(I) = Y(I) 10 CONTINUE 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 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, 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 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 *** V SUBSCRIPT VALUES *** C 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 PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0) 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 c GO TO (250, 250, 250, 250, 250, 250, 190, 150, 190, 20, 20, 30), I select case(I) case(1:6) goto 250 case(7,9) goto 190 case(8) goto 150 case(10,11) goto 20 case(12) goto 30 end select 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()) 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 c GO TO (300, 270, 280, 290), I select case(I) case(1) goto 300 case(2) goto 270 case(3) goto 280 case(4) goto 290 end select 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) c GO TO (310,340,340,340,310,320,330,330,330,330,330,330,400,370), K select case(K) case(1,5) goto 310 case(2:4) goto 340 case(6) goto 320 case(7:12) goto 330 case(13) goto 400 case(14) goto 370 end select 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 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 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) PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C C--------------------------------- BODY ------------------------------ C IF (IRC .LT. 0) GO TO 140 IF (IRC .GT. 0) GO TO 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 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 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(*), L(*), V(21), STEP(P), 1 W(*) 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 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 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 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 W(I) = ZERO 40 CONTINUE 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 W(I) = ZERO 230 CONTINUE 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 W(I) = T*W(I) 350 CONTINUE 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 W(I) = T2*W(I) 360 CONTINUE 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 RETURN C C *** LAST CARD OF DG7QTS 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(*), 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 PARAMETER (EPS=0.1D+0, ONE=1.D+0) 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 Z(I) = CY * Z(I) - CS * W(I) 30 CONTINUE C RETURN C *** LAST CARD OF DW7ZBF FOLLOWS *** 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 PARAMETER (CNVCOD=55, COVMAT=26, F=10, FDH=74, H=56, MODE=35, 1 RDREQ=57, REGD=67) 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 * DBLE(MAX0(1,N-P))), V(COV)) IV(COVMAT) = COV C 999 RETURN C *** LAST LINE OF DC7VFN 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 DOUBLE PRECISION X(*), Y(N), Z(*) 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 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(*), Y(N) DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR INTEGER I, J, K DOUBLE PRECISION T, ZERO PARAMETER (ZERO=0.D+0) 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 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 PARAMETER (DFAC=41, DTYPE=16, JCN=66, JTOL=59, NITER=31, S=62) C PARAMETER (ZERO=0.D+0) 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 T = DMAX1(T, DABS(DR(K,I))) 20 CONTINUE 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 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 X(I) = X(I+1) 10 CONTINUE X(N) = T 999 RETURN 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 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) PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C C--------------------------------- BODY ------------------------------ C IF (IRC .LT. 0) GO TO 80 IF (IRC .GT. 0) GO TO 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 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 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(*), LAMBDA(N), LPLUS(*), 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 PARAMETER (ONE=1.D+0, ZERO=0.D+0) 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 RETURN C *** LAST CARD OF DL7UPD 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 RETURN C *** LAST CARD OF DO7PRD 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 X(I) = Y(I) / Z(I) 10 CONTINUE GO TO 999 C 20 DO 30 I = 1, N X(I) = Y(I) * Z(I) 30 CONTINUE 999 RETURN C *** LAST CARD OF DV7VMP 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(M+1),JPNTR(N+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,NPAIRS,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(M,N,NPAIRS,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,NPAIRS,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 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 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(*), L(*) 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 A(J) = LII * L(J) 40 CONTINUE 50 CONTINUE C RETURN C *** LAST CARD OF DL7TSQ 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 PARAMETER (ZERO=0.D+0) 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 RETURN C *** LAST CARD OF DRLDST 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 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 *** V SUBSCRIPT VALUES *** C PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) PARAMETER (HALF=0.5D+0, ZERO=0.D+0) 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) THEN C GO TO (150, 130, 150, 120, 120, 150), I select case(I) case(1,3,6) goto 150 case(2) goto 130 case(4,5) goto 120 end select END IF 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) .EQ. 2) GO TO 60 IF (IV(1) .GT. 2) GO TO 260 C 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 260 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 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 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 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) PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0) SAVE MEPS2 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 TG(I) = T2*TG(I) - T1*W(I) 80 CONTINUE 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 RETURN C *** LAST LINE OF DD7DGB 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 PARAMETER (ONE=1.0D+0, TEN=1.D+1, WTOL=0.75D+0, ZERO=0.0D+0) SAVE BIGRT, MEPS10, TINY, TINYRT 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 = DBLE(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 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 PARAMETER (HALF=0.5D+0, HLIM=0.1D+0, ONE=1.D+0, TWO=2.D+0, 1 ZERO=0.D+0) C 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+++++++++++++++++++++++++++++++ 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 c 310 GO TO (160, 220, 320), NEWM1 310 continue select case(NEWM1) case(1) goto 160 case(2) goto 220 case(3) goto 320 end select 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