SUBROUTINE RN2GB(B, D, DR, IV, LIV, LV, N, ND, N1, N2, P, R, 1 RD, V, X) C C *** REVISED ITERATION DRIVER FOR NL2SOL WITH SIMPLE BOUNDS *** C INTEGER LIV, LV, N, ND, N1, N2, P INTEGER IV(LIV) REAL B(2,P), D(P), DR(ND,P), R(ND), RD(ND), V(LV), 1 X(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B........ BOUNDS ON X. C D........ SCALE VECTOR. C DR....... DERIVATIVES OF R AT X. C IV....... INTEGER VALUES ARRAY. C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82. C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20). C N........ TOTAL NUMBER OF RESIDUALS. C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL. C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C R........ RESIDUALS. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** DISCUSSION *** C C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR C LEAST SQUARES PROBLEMS. IT IS SIMILAR TO RN2G, EXCEPT THAT C THIS ROUTINE ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL IVSET, D7TPR, D7UPD, G7ITB, ITSUM, L7VML, Q7APL, 1 Q7RAD, R7TVM, V7CPY, V7SCP, V2NRM C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C D7UPD... UPDATES SCALE VECTOR D. C G7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM. C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C Q7APL... APPLIES QR TRANSFORMATIONS STORED BY Q7RAD. C Q7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION. C R7TVM... MULT. VECTOR BY TRANS. OF UPPER TRIANG. MATRIX FROM QR FACT. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C C C *** LOCAL VARIABLES *** C INTEGER G1, GI, I, IV1, IVMODE, JTOL1, L, LH, NN, QTR1, 1 RD1, RMAT1, YI, Y1 REAL T C REAL HALF, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, G, JCN, JTOL, MODE, 1 NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, QTR, RDREQ, 1 REGD, RESTOR, RLIMIT, RMAT, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C C/6 C DATA DTYPE/16/, G/28/, JCN/66/, JTOL/59/, MODE/35/, NEXTV/47/, C 1 NF0/68/, NF00/81/, NF1/69/, NFCALL/6/, NFCOV/52/, NFGCAL/7/, C 2 QTR/77/, RDREQ/57/, RESTOR/9/, REGD/67/, RMAT/78/, TOOBIG/2/, C 3 VNEED/4/ C/7 PARAMETER (DTYPE=16, G=28, JCN=66, JTOL=59, MODE=35, NEXTV=47, 1 NF0=68, NF00=81, NF1=69, NFCALL=6, NFCOV=52, NFGCAL=7, 2 QTR=77, RDREQ=57, RESTOR=9, REGD=67, RMAT=78, TOOBIG=2, 3 VNEED=4) C/ C C *** V SUBSCRIPT VALUES *** C C/6 C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/ C/7 PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46) C/ C/6 C DATA HALF/0.5E+0/, ZERO/0.E+0/ C/7 PARAMETER (HALF=0.5E+0, ZERO=0.E+0) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 NN = N2 - N1 + 1 IV(RESTOR) = 0 I = IV1 + 4 IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I IF (I .NE. 5) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LE. 0) GO TO 220 IF (P .LE. 0) GO TO 220 IF (N .LE. 0) GO TO 220 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 270 IF (IV1 .LT. 12) GO TO 40 IF (IV1 .EQ. 12) IV(1) = 13 IF (IV(1) .NE. 13) GO TO 20 IV(VNEED) = IV(VNEED) + P*(P+15)/2 20 CALL G7ITB(B, D, X, IV, LIV, LV, P, P, V, X, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(G) = IV(NEXTV) IV(JCN) = IV(G) + 2*P IV(RMAT) = IV(JCN) + P IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + 2*P IV(NEXTV) = IV(JTOL) + 2*P C *** TURN OFF COVARIANCE COMPUTATION *** IV(RDREQ) = 0 IF (IV1 .EQ. 13) GO TO 999 C 30 JTOL1 = IV(JTOL) IF (V(DINIT) .GE. ZERO) CALL V7SCP(P, D, V(DINIT)) IF (V(DTINIT) .GT. ZERO) CALL V7SCP(P, V(JTOL1), V(DTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL V7SCP(P, V(I), V(D0INIT)) IV(NF0) = 0 IV(NF1) = 0 IF (ND .GE. N) GO TO 40 C C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE C G1 = IV(G) Y1 = G1 + P CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 1) GO TO 260 V(F) = ZERO CALL V7SCP(P, V(G1), ZERO) IV(1) = -1 QTR1 = IV(QTR) CALL V7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 RMAT1 = IV(RMAT) GO TO 100 C 40 G1 = IV(G) Y1 = G1 + P CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 260 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 240 IF (IV(RESTOR) .NE. 2) GO TO 240 IV(NF0) = IV(NF1) CALL V7CPY(N, RD, R) IV(REGD) = 0 GO TO 240 C 60 CALL V7SCP(P, V(G1), ZERO) IF (IV(MODE) .GT. 0) GO TO 230 RMAT1 = IV(RMAT) QTR1 = IV(QTR) RD1 = QTR1 + P CALL V7SCP(P, V(QTR1), ZERO) IV(REGD) = 0 IF (ND .LT. N) GO TO 90 IF (N1 .NE. 1) GO TO 90 IF (IV(MODE) .LT. 0) GO TO 100 IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70 IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90 CALL V7CPY(N, R, RD) GO TO 80 70 CALL V7CPY(N, RD, R) 80 CALL Q7APL(ND, N, P, DR, RD, 0) CALL R7TVM(ND, MIN0(N,P), V(Y1), V(RD1), DR, RD) IV(REGD) = 0 GO TO 110 C 90 IV(1) = -2 IF (IV(MODE) .LT. 0) IV(1) = -3 100 CALL V7SCP(P, V(Y1), ZERO) 110 CALL V7SCP(LH, V(RMAT1), ZERO) GO TO 240 C C *** COMPUTE F(X) *** C 120 T = V2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 210 V(F) = V(F) + HALF * T**2 IF (N2 .LT. N) GO TO 250 IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL) GO TO 40 C C *** COMPUTE Y *** C 130 Y1 = IV(G) + P YI = Y1 DO 140 L = 1, P V(YI) = V(YI) + D7TPR(NN, DR(1,L), R) YI = YI + 1 140 CONTINUE IF (N2 .LT. N) GO TO 250 IV(1) = 2 IF (N1 .GT. 1) IV(1) = -3 GO TO 240 C C *** COMPUTE GRADIENT INFORMATION *** C 150 G1 = IV(G) IVMODE = IV(MODE) IF (IVMODE .LT. 0) GO TO 170 IF (IVMODE .EQ. 0) GO TO 180 IV(1) = 2 C C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) *** C GI = G1 DO 160 L = 1, P V(GI) = V(GI) + D7TPR(NN, R, DR(1,L)) GI = GI + 1 160 CONTINUE GO TO 200 C C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N *** C 170 IF (N .LE. ND) GO TO 180 T = V2NRM(NN, R) IF (T .GT. V(RLIMIT)) GO TO 210 V(F) = V(F) + HALF * T**2 C C *** UPDATE D IF DESIRED *** C 180 IF (IV(DTYPE) .GT. 0) 1 CALL D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V) C C *** COMPUTE RMAT AND QTR *** C QTR1 = IV(QTR) RMAT1 = IV(RMAT) CALL Q7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R) IV(NF1) = 0 IF (N1 .GT. 1) GO TO 200 IF (N2 .LT. N) GO TO 250 C C *** SAVE DIAGONAL OF R FOR COMPUTING Y LATER *** C RD1 = QTR1 + P L = RMAT1 - 1 DO 190 I = 1, P L = L + I V(RD1) = V(L) RD1 = RD1 + 1 190 CONTINUE C 200 IF (N2 .LT. N) GO TO 250 IF (IVMODE .GT. 0) GO TO 40 IV(NF00) = IV(NFGCAL) C C *** COMPUTE G FROM RMAT AND QTR *** C CALL L7VML(P, V(G1), V(RMAT1), V(QTR1)) IV(1) = 2 IF (IVMODE .EQ. 0) GO TO 40 IF (N .LE. ND) GO TO 40 C C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT C Y1 = G1 + P IV(1) = 1 CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1)) IF (IV(1) .NE. 2) GO TO 260 GO TO 40 C C *** MISC. DETAILS *** C C *** X IS OUT OF RANGE (OVERSIZE STEP) *** C 210 IV(TOOBIG) = 1 GO TO 40 C C *** BAD N, ND, OR P *** C 220 IV(1) = 66 GO TO 270 C C *** RECORD EXTRA EVALUATIONS FOR FINITE-DIFFERENCE HESSIAN *** C 230 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 C C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION *** C 240 N2 = 0 250 N1 = N2 + 1 N2 = N2 + ND IF (N2 .GT. N) N2 = N GO TO 999 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 260 G1 = IV(G) 270 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X) C 999 RETURN C *** LAST CARD OF RN2GB FOLLOWS *** END