C ALGORITHM 717, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 19, NO. 1, MARCH, 1993, PP. 109-130. cat >README <<'//GO.SYSIN DD README' Subroutines for Maximum Likelihood and Quasi-Likelihood Estimation of Parameters in Nonlinear Regression Models by David S. Bunch (UC Davis), David M. Gay (AT&T Bell Laboratories), and Roy E. Welsch (MIT); submission to ACM Transactions on Mathematical Software. _____________ Preliminaries ============= To use the Fortran subroutines and main programs in this large file, you need to split it into its 53 constituent files. The first of these logical files is called README, which includes the text you are reading now, as well as additional information for linking and running the test programs. The instructions for decomposing the files is given next, followed by the remainder of README, and then the other files. ____________________ Splitting into Files ==================== If you are using a UNIX system, just feed this file to /bin/sh (in an empty directory), as in sh thisfilename Alternatively, you can feed this file to the Fortran program shown below. You could also split this large file up by hand: each constituent file is preceded by a line of the form cat >filename <<'//GO.SYSIN DD filename' and followed by a corresponding line of the form //GO.SYSIN DD filename We've indented the above lines here for display purposes, but the real lines start in column 1. Here is the promised Fortran program for decomposing this file. On some systems you will need to make a change in format statement 90, as described in the comment below. PROGRAM UNPACK CHARACTER*100 LINE, TERMIN CHARACTER*16 FNAME INTEGER FNLEN, I, LINENO, OUTFIL PARAMETER (OUTFIL=1) LINENO = 0 10 READ(*,'(A)',END=999) LINE LINENO = LINENO + 1 IF (LINE(1:5) .NE. 'cat >') CALL BADCAT(LINE, LINENO) DO 20 I = 6, 100 IF (LINE(I:I) .EQ. ' ') GO TO 30 20 CONTINUE CALL BADCAT(LINE, LINENO) 30 FNAME = LINE(6:I) FNLEN = I - 5 IF (LINE(I+1:I+17) .NE. '<<''//GO.SYSIN DD ') 1 CALL BADCAT(LINE, LINENO) IF (LINE(I+18:I+16+FNLEN) .NE. FNAME) 1 CALL BADCAT(LINE, LINENO) TERMIN = LINE(I+4:I+FNLEN+16) OPEN(OUTFIL,FILE=FNAME,STATUS='NEW',ERR=40) GO TO 60 40 OPEN(OUTFIL,FILE=FNAME,STATUS='OLD',ERR=50) WRITE(*,*) 'overwriting ',FNAME(1:FNLEN) GO TO 70 50 WRITE(*,*) 'cannot open ',FNAME(1:FNLEN) GO TO 999 60 WRITE(*,*) FNAME(1:FNLEN) 70 LINENO = LINENO + 1 READ(*,'(A)',END=100) LINE IF (LINE .EQ. TERMIN) THEN CLOSE(OUTFIL) GO TO 10 END IF DO 80 I = 100, 1, -1 IF (LINE(I:I) .NE. ' ') GO TO 90 80 CONTINUE ******** On systems where carriage controls end up in written files ******** (to be honored by a printer or subsequent program), such as ******** VAX VMS and most UNIX systems, you need to omit "1X," ******** in the following WRITE statement, changing it to *90 WRITE(OUTFIL,'(A)') LINE(I:I) 90 WRITE(OUTFIL,'(1X,A)') LINE(1:I) GO TO 70 100 WRITE(*,*) 'Premature end of file' 999 END SUBROUTINE BADCAT(LINE, LINENO) CHARACTER*100 LINE INTEGER LINENO WRITE(*,*) 'Line ', LINENO, ': Bad "cat" line:' WRITE(*, '(A)') LINE STOP END ________ Overview ======== Information is given below regarding subroutines and test programs, including how to link and run the test programs. There are five basic test programs: MADSEN (simple test problems, no bounds on parameters) MADSENB (simple test problems, with bounds on parameters) PMAIN (problems from Gay and Welsch 1988, mix of bounds and no bounds) MLMNP (multinomial probit estimation problems from Bunch 1991, no bounds) MLMNPB (" ", with bounds) These exist in both single- and double-precision versions. The following two documents are available from the authors: "Driver PMAIN for DGL[FG][B ]", by David M. Gay. "MLMNP and MLMNPB: Fortran Programs for Maximum Likelihood Estimation of Linear-in-Parameter Multinomial Probit Models", by David S. Bunch. Postscript for these documents is or will be available from netlib. For details, send netlib@research.att.com the one-line electronic mail message send index from opt/nlr MADSEN and MADSENB do not require input. PMAIN has a single sample input file for producing test results, but can also be run interactively or with other input files; see the "Driver PMAIN" document. MLMNP and MLMNPB require input files for Fortran units 1 and 2; four examples are included. ____________________ Machine dependencies ==================== There are two machine-dependent files, dmdc.f and smdc.f (double- and single-precision versions, respectively), which provide machine constants. You must activate (i.e., remove the 'C' from column 1) the lines that pertain to your machine, or that pertain to the PORT routines D1MACH (for dmdc.f) and R1MACH (for smdc.f), if you choose to use those routines (which have constants for a much wider selection of machines than do dmdc.f and smdc.f). __________ Precisions ========== As previously noted, we've provided both single- and double-precision versions of our optimization subroutines and test problems. If you are a referee, you may want to try both; otherwise, unless you are using a Cray or CDC machine (or something similar whose single precision has substantially more accuracy than does binary IEEE aritihmetic), you are probably better off using the double-precision routines. ________ makefile ======== If you are using a UNIX system, you can probably just type make to cause everything to be compiled and all test programs to be run. If you run the single-precision tests on a 32-bit computer, you may get a few instances of FALSE or SINGULAR CONVERGENCE. For comparison purposes, we include *.sgi files, which are *.out files we obtained on an SGI computer (IEEE arithmetic; compilation was with f2c and cc). We note, however, that many of the test problems are very nonlinear, and differences in compilers and machines will often produce slightly different output. ____________________________________ Opening files from the test programs ==================================== To run the MLMNP and MLMNPB programs, you may need to adjust the OPEN and REWIND statements near the beginning of mlmnp.f and mlmnpb.f (for double-precision, or smlmnp.f and smlmnpb.f for single). ________________ Summary of files ================ 1. README This file. 2. makefile For UNIX systems; encodes the information below about what files are needed for what programs. DOUBLE PRECISION SOURCE FILES 3. dmdc.f0 Edit this into dmdc.f . 4. dglfg.f Top-level routines DGLG, DGLF, DRGLG (no bounds), followed by routines they call that are not in dgletc.f . 5. dglfgb.f Top-level routines DGLGB, DGLFB, DRGLGB (simple bounds), followed by routines they call that are not in dgletc.f . 6. dgletc.f Routines needed whether or not there are simple bounds. 7. madsen.f Simple example program, no bounds. Needs dmdc.f, dglfg.f, dgletc.f . 8. madsenb.f Simple test program, variant of madsen.f with bounds. Needs dmdc.f, dglfgb.f, dgletc.f . 9. dpmain.f General test program PMAIN. Needs dmdc.f, dglfg.f, dglfgb.f, dgletc.f, and mecdf.f . 10. mecdf.f Computes approximation to multivariate normal cumulative distribution function (uses Mendell- Elston approximation.) 11. mlmnp.f Program MLMNP for linear-in-parameter multinomial probit models, no bounds. Needs dmdc.f, dglfg.f, dgletc.f, mecdf.f, mnpsubs.f . 12. mlmnpb.f Program MLMNPB for linear-in-parameter multinomial probit models with simple bounds. Needs dmdc.f, dglfgb.f, dgletc.f, mecdf.f, mnpsubs.f . 13. mnpsubs.f Needed by mlmnp.f and mlmnpb.f . TEST DATA FILES 14. pmain.in Input for PMAIN (from Gay & Welsch, 1988). The following *.fu? files are input for MLMNP and MLMNPB. The files named *.fu1 are to be read by Fortran unit 1, and those named *.fu2 are to be read by Fortran unit 2. 15. daganzo.fu2 Choice data set from Daganzo (1979). 16. mnpex1.fu1 Example 1: a model to use with daganzo.fu2 17. mnpex2.fu1 Example 2: another model to use with daganzo.fu2 18. rent.fu2 Choice data set from MBA survey on rental housing 19. rent1.fu1 Example 3: a model to use with rent.fu2 20. rent2.fu1 Example 4: another model to use with rent.fu2 SINGLE PRECISION SOURCE FILES corresponding to files 3-13. 21. smdc.f0 Edit this into smdc.f . 22. sglfg.f 23. sglfgb.f 24. sgletc.f 25. smadsen.f 26. smadsenb.f 27. spmain.f 28. smecdf.f 29. smlmnp.f 30. smlmnpb.f 31. smnpsubs.f SAMPLE OUTPUTS, DOUBLE PRECISION 32. madsen.sgi 33. madsenb.sgi 34. mnpex1.sgi 35. mnpex1b.sgi 36. mnpex2.sgi 37. mnpex2b.sgi 38. pmain.sgi 39. rent1.sgi 40. rent1b.sgi 41. rent2.sgi 42. rent2b.sgi SAMPLE OUTPUTS, SINGLE PRECISION 43. smadsen.sgi 44. smadsenb.sgi 45. smnpex1.sgi 46. smnpex1b.sgi 47. smnpex2.sgi 48. smnpex2b.sgi 49. spmain.sgi 50. srent1.sgi 51. srent1b.sgi 52. srent2.sgi 53. srent2b.sgi //GO.SYSIN DD README cat >makefile <<'//GO.SYSIN DD makefile' .SUFFIXES: .f .o FFLAGS = -u F77 = f77 L = .f.o: $(F77) -c $(FFLAGS) $*.f both: out sout out: madsen.out madsenb.out pmain.out mnpex1.out mnpex1b.out \ mnpex2.out mnpex2b.out rent1.out rent1b.out rent2.out rent2b.out sout: smadsen.out smadsenb.out spmain.out smnpex1.out smnpex1b.out \ smnpex2.out mnpex2b.out srent1.out srent1b.out srent2.out srent2b.out dmdc.f: dmdc.f0 true # Obtain dmcd.f from dmdc.f0 by activating the statements false # appropriate to your machine smdc.f: smdc.f0 true # Obtain dmcd.f from smdc.f0 by activating the statements false # appropriate to your machine madsen.out: madsen.f dglfg.o dgletc.o dmdc.o $(F77) madsen.f dglfg.o dgletc.o dmdc.o $L a.out >$@ madsenb.out: madsenb.f dglfgb.o dgletc.o dmdc.o $(F77) madsenb.f dglfgb.o dgletc.o dmdc.o $L a.out >$@ pmain: dpmain.o mecdf.o dglfg.o dglfgb.o dgletc.o dmdc.o $(F77) dpmain.o mecdf.o dglfg.o dglfgb.o dgletc.o dmdc.o $L -o $@ pmain.out: pmain pmain.in pmain $@ mlmnp: mlmnp.o mecdf.o mnpsubs.o dglfg.o dgletc.o dmdc.o $(F77) mlmnp.o mecdf.o mnpsubs.o dglfg.o dgletc.o dmdc.o $L -o $@ mlmnpb: mlmnpb.o mecdf.o mnpsubs.o dglfgb.o dgletc.o dmdc.o $(F77) mlmnpb.o mecdf.o mnpsubs.o dglfgb.o dgletc.o dmdc.o $L -o $@ mnpex1.out mnpex1b.out: mlmnp mlmnpb mnpex1.fu1 daganzo.fu2 rm -f fort.? ln mnpex1.fu1 fort.1 ln daganzo.fu2 fort.2 mlmnp >mnpex1.out mlmnpb >mnpex1b.out mnpex2.out mnpex2b.out: mlmnp mlmnpb mnpex2.fu1 daganzo.fu2 rm -f fort.? ln mnpex2.fu1 fort.1 ln daganzo.fu2 fort.2 mlmnp >mnpex2.out mlmnpb >mnpex2b.out rent1.out rent1b.out: mlmnp mlmnpb rent1.fu1 rent.fu2 rm -f fort.? ln rent1.fu1 fort.1 ln rent.fu2 fort.2 mlmnp >rent1.out mlmnpb >rent1b.out rent2.out rent2b.out: mlmnp mlmnpb rent2.fu1 rent.fu2 rm -f fort.? ln rent2.fu1 fort.1 ln rent.fu2 fort.2 mlmnp >rent2.out mlmnpb >rent2b.out # single-precision runs... smadsen.out: smadsen.f sglfg.o sgletc.o smdc.o $(F77) smadsen.f sglfg.o sgletc.o smdc.o $L a.out >$@ smadsenb.out: smadsenb.f sglfgb.o sgletc.o smdc.o $(F77) smadsenb.f sglfgb.o sgletc.o smdc.o $L a.out >$@ spmain: spmain.o smecdf.o sglfg.o sglfgb.o sgletc.o smdc.o $(F77) spmain.o smecdf.o sglfg.o sglfgb.o sgletc.o smdc.o $L -o $@ spmain.out: spmain pmain.in spmain $@ smlmnp: smlmnp.o smecdf.o smnpsubs.o sglfg.o sgletc.o smdc.o $(F77) smlmnp.o smecdf.o smnpsubs.o sglfg.o sgletc.o smdc.o $L -o $@ smlmnpb: smlmnpb.o smecdf.o smnpsubs.o sglfgb.o sgletc.o smdc.o $(F77) smlmnpb.o smecdf.o smnpsubs.o sglfgb.o sgletc.o smdc.o $L -o $@ smnpex1.out smnpex1b.out: smlmnp smlmnpb mnpex1.fu1 daganzo.fu2 rm -f fort.? ln mnpex1.fu1 fort.1 ln daganzo.fu2 fort.2 smlmnp >smnpex1.out smlmnpb >smnpex1b.out smnpex2.out smnpex2b.out: smlmnp smlmnpb mnpex2.fu1 daganzo.fu2 rm -f fort.? ln mnpex2.fu1 fort.1 ln daganzo.fu2 fort.2 smlmnp >smnpex2.out smlmnpb >smnpex2b.out srent1.out srent1b.out: smlmnp smlmnpb rent1.fu1 rent.fu2 rm -f fort.? ln rent1.fu1 fort.1 ln rent.fu2 fort.2 smlmnp >srent1.out smlmnpb >srent1b.out srent2.out srent2b.out: smlmnp smlmnpb rent2.fu1 rent.fu2 rm -f fort.? ln rent2.fu1 fort.1 ln rent.fu2 fort.2 smlmnp >srent2.out smlmnpb >srent2b.out clean: rm -f *.out *.o pmain mlmnp mlmnpb spmain smlmnp smlmnpb //GO.SYSIN DD makefile cat >dmdc.f0 <<'//GO.SYSIN DD dmdc.f0' DOUBLE PRECISION FUNCTION DR7MDC(K) C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C C +++ COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES. +++ C +++ TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE +++ C +++ DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++ C +++ AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S) +++ C +++ THAT CORRESPOND TO THE NEW MACHINE. +++ 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, ZERO INTEGER BIGI(2), ETAI(2), MACHEI(2) EQUIVALENCE (BIG,BIGI(1)), (ETA,ETAI(1)), (MACHEP,MACHEI(1)) PARAMETER (ZERO=0.D+0) C C +++ IEEE ARITHMETIC MACHINES IN WHICH THE MOST SIGNIFICANT BYTE C +++ IS STORED FIRST, SUCH AS THE AT&T 3B SERIES AND MACHINES C +++ BASED ON SPARC, MIPS, AND MOTOROLA 68XXX PROCESSORS. C C DATA BIGI(1),BIGI(2) / 2146435071, -1 / C DATA ETAI(1),ETAI(2) / 1048576, 0 / C DATA MACHEI(1),MACHEI(2) / 1017118720, 0 / C C +++ IEEE ARITHMETIC MACHINES IN WHICH THE LEAST SIGNIFICANT BYTE C +++ IS STORED FIRST, SUCH AS MACHINES BASED ON INTEL PROCESSORS, C +++ E.G. PERSONAL COMPUTERS WITH AN INTEL 80X87. C C DATA BIGI(1),BIGI(2) / -1, 2146435071 / C DATA ETAI(1),ETAI(2) / 0, 1048576 / C DATA MACHEI(1),MACHEI(2) / 0, 1017118720 / C C +++ IBM, AMDAHL, OR XEROX MAINFRAME +++ C C DATA BIGI(1),BIGI(2)/2147483647, -1/ C DATA ETAI(1),ETAI(2)/1048576, 0/ C DATA MACHEI(1),MACHEI(2)/873463808,0/ C C +++ VAX +++ C C DATA BIGI(1),BIGI(2) / -32769, -1 / C DATA ETAI(1),ETAI(2) / 128, 0 / C DATA MACHEI(1),MACHEI(2) / 9344, 0 / C C +++ CRAY +++ C C DATA BIGI(1)/6917247552664371199/ C DATA BIGI(2)/128891879815246481/ C DATA ETAI(1)/2332160919536140288/ C DATA ETAI(2)/0/ C DATA MACHEI(1)/4585931058058362880/ C DATA MACHEI(2)/0/ C C +++ PORT LIBRARY -- REQUIRES MORE THAN JUST A DATA STATEMENT, +++ C +++ BUT HAS CONSTANTS FOR MANY MORE MACHINES. +++ C C To get the current D1MACH, which has constants for many more C machines, ask netlib@research.att.com to C send d1mach from cor C For machines with rounded arithmetic (e.g., IEEE or VAX arithmetic), C use MACHEP = 0.5D0 * D1MACH(4) below. C C DOUBLE PRECISION D1MACH C EXTERNAL D1MACH C DATA BIG/0.D+0/, ETA/0.D+0/, MACHEP/0.D+0/, ZERO/0.D+0/ C IF (BIG .GT. ZERO) GO TO 1 C BIG = D1MACH(2) C ETA = D1MACH(1) C MACHEP = D1MACH(4) C1 CONTINUE C C +++ END OF PORT +++ C C------------------------------- BODY -------------------------------- C IF (MACHEP .LE. ZERO) THEN WRITE(*,*) 'Edit DR7MDC to activate the appropriate statements' STOP 987 ENDIF GO TO (10, 20, 30, 40, 50, 60), K C 10 DR7MDC = ETA GO TO 999 C 20 DR7MDC = SQRT(256.D+0*ETA)/16.D+0 GO TO 999 C 30 DR7MDC = MACHEP GO TO 999 C 40 DR7MDC = SQRT(MACHEP) GO TO 999 C 50 DR7MDC = SQRT(BIG/256.D+0)*16.D+0 GO TO 999 C 60 DR7MDC = BIG C 999 RETURN C *** LAST LINE OF DR7MDC FOLLOWS *** END INTEGER FUNCTION I7MDCN(K) C INTEGER K C C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS *** C C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. *** C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. *** C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. *** C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.) C C +++ PORT VERSION FOLLOWS... C INTEGER I1MACH C EXTERNAL I1MACH C INTEGER MDPERM(3) C DATA MDPERM(1)/2/, MDPERM(2)/4/, MDPERM(3)/1/ C I7MDCN = I1MACH(MDPERM(K)) C +++ END OF PORT VERSION +++ C C +++ NON-PORT VERSION FOLLOWS... INTEGER MDCON(3) DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/ I7MDCN = MDCON(K) C +++ END OF NON-PORT VERSION +++ C 999 RETURN C *** LAST LINE OF I7MDCN FOLLOWS *** END //GO.SYSIN DD dmdc.f0 cat >dglfg.f <<'//GO.SYSIN DD dglfg.f' SUBROUTINE DGLG(N, P, PS, X, RHO, RHOI, RHOR, IV, LIV, LV, V, 1 CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION A LA NL2SOL *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) DOUBLE PRECISION X(*), RHOR(*), V(LV), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE DRGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV, AT LEAST 90 + P. C LV...... LENGTH OF V, AT LEAST C 105 + P*(3*P + 16) + 2*N + 4*PS C + N*(P + 1 + (P-PS+1)*(P-PS+2)/2). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR AND JACOBIAN MATRIX. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED IS AN INTEGER ARRAY OF LENGTH 2... C NEED(1) = 1 MEANS CALCRJ SHOULD COMPUTE THE RESIDUAL VECTOR R, C AND NEED(2) IS THE VALUE NF HAD AT THE LAST X WHERE C CALCRJ MIGHT BE CALLED WITH NEED(1) = 2. C NEED(1) = 2 MEANS CALCRJ SHOULD COMPUTE THE JACOBIAN MATRIX RP, C WHERE RP(J,I) = DERIVATIVE OF R(I) WITH RESPECT TO X(J). C (CALCRJ SHOULD NOT CHANGE NEED AND SHOULD CHANGE AT MOST ONE OF R C AND RP. IF R OR RP, AS APPROPRIATE, CANNOT BE COMPUTED, THEN CALCRJ C SHOULD SET NF TO 0. OTHERWISE IT SHOULD NOT CHANGE NF.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRGLG C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRGLG ... CARRIES OUT OPTIMIZATION ITERATIONS. C C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, I, IV1, NEED1(2), NEED2(2), NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+1+I) CALL DRGLG(X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, RHO, RHOI, 1 RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 1)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL DRGLG(V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, V(R1), 1 V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 60 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL CALCRJ(N, PS, X, NF, NEED1, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCRJ(N, PS, X, IV(NFGCAL), NEED2, V(R1), V(DR1), UI, UR,UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED C *** AND PRINT IT IF SO REQUESTED... C 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 C 999 RETURN C C *** LAST LINE OF DGLG FOLLOWS *** END SUBROUTINE DGLF(N, P, PS, X, RHO, RHOI, RHOR, IV, LIV, LV, V, 1 CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION, FINITE-DIFFERENCE JACOBIAN *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) DOUBLE PRECISION X(*), V(LV), RHOR(*), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE DRGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV, AT LEAST 90 + P. C LV...... LENGTH OF V, AT LEAST C 105 + P*(3*P + 16) + 2*N + 4*PS C + N*(P + 3 + (P-PS+1)*(P-PS+2)/2). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED MAY BE REGARDED AS AN INTEGER THAT ALWAYS HAS THE VALUE 1 C WHEN DGLF CALLS CALCRJ. THIS MEANS CALCRJ SHOULD COMPUTE THE C RESIDUAL VECTOR R. (CALCRJ SHOULD NOT CHANGE NEED OR RP. IF R C CANNOT BE COMPUTED, THEN CALCRJ SHOULD SET NF TO 0. OTHERWISE IT C SHOULD NOT CHANGE NF. FOR COMPATIBILITY WITH DGLG, NEED IS A C VECTOR OF LENGTH 2.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRGLG,DV7CPY C C DIVSET... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRGLG... CARRIES OUT OPTIMIZATION ITERATIONS. C DV7CPY... COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, I1, IV1, J1K, J1K0, K, NEED(2), NF, 1 NG, RD1, R1, R21, RN, RS1 DOUBLE PRECISION H, H0, HLIM, NEGPT5, ONE, XK, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, RDREQ, REGD, REGD0, TOOBIG, VNEED PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, RDREQ=57, REGD=67, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED DATA HLIM/0.1D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ DATA NEED(1)/1/, NEED(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IF (IV(COVREQ) .EQ. 0 .AND. IV(RDREQ) .GT. 0) IV(COVREQ) = -1 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+3+I) CALL DRGLG(X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, RHO, RHOI, 1 RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 3)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) R21 = RD1 - N RS1 = R21 - N RN = RS1 + N - 1 C 20 CALL DRGLG(V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, V(R1), 1 V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 120 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCRJ(N, PS, X, NF, NEED, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 CALL DV7CPY(N, V(RS1), V(R1)) IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL DV7SCP(P, V(D1), ONE) C DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 J1K0 = DR1 NF = IV(NFCALL) IF (NF .EQ. IV(NFGCAL)) GO TO 70 NG = NG + 1 CALL CALCRJ(N, PS, X, NF, NEED, V(RS1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 70 60 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 70 DO 110 K = 1, PS XK = X(K) H = V(DLTFDJ) * MAX( ABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 80 X(K) = XK + H NG = NG + 1 NF = -NG CALL CALCRJ(N, PS, X, NF, NEED, V(R21), V(DR1), UI, UR, UF) IF (NF .LT. 0) GO TO 90 H = NEGPT5 * H IF ( ABS(H/H0) .GE. HLIM) GO TO 80 GO TO 60 90 X(K) = XK IV(NGCALL) = NG I1 = R21 J1K = J1K0 J1K0 = J1K0 + 1 DO 100 I = RS1, RN V(J1K) = (V(I1) - V(I)) / H I1 = I1 + 1 J1K = J1K + PS 100 CONTINUE 110 CONTINUE GO TO 20 C 120 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 C 999 RETURN C C *** LAST LINE OF DGLF FOLLOWS *** END SUBROUTINE DRGLG(D, DR, IV, LIV, LV, N, ND, NN, P, PS, R, 1 RD, RHO, RHOI, RHOR, V, X) C C *** ITERATION DRIVER FOR GENERALIZED (NON)LINEAR MODELS (ETC.) C INTEGER LIV, LV, N, ND, NN, P, PS INTEGER IV(LIV), RHOI(*) DOUBLE PRECISION D(P), DR(ND,N), R(*), RD(*), RHOR(*), 1 V(LV), X(*) C DIMENSION RD(N, (P-PS)*(P-PS+1)/2 + 1) EXTERNAL RHO 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 + 90. C LV...... LENGTH OF V... LV MUST BE AT LEAST C 105 + P*(2*P+16) + 2*N + 4*PS. C N....... TOTAL NUMBER OF RESIDUALS. C ND...... LEADING DIMENSION OF DR -- MUST BE AT LEAST PS. C NN...... LEAD DIMENSION OF R, RD. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS. C R....... RESIDUALS (OR MEANS -- FUNCTIONS OF X) WHEN DRGLG IS CALLED C WITH IV(1) = 1. C RD...... RD(I) = HALF * (G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN C IV(RDREQ) IS 2, 3, 5, OR 6. DRGLG 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. BEFORE CONVERGENCE, RD IS ALSO USED AS C TEMPORARY STORAGE. C RHO..... COMPUTES INFO ABOUT OBJECTIVE FUNCTION. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C V....... FLOATING-POINT VALUES ARRAY. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** CALLING SEQUENCE FOR RHO... C C CALL RHO(NEED, F, N, NF, XN, R, RD, RHOI, RHOR, W) C C PARAMETER DECLARATIONS FOR RHO... C C INTEGER NEED(2), N, NF, RHOI(*) C FLOATING-POINT F, XN(*), R(*), RD(N,*), RHOR(*), W(N) C C RHOI AND RHOR ARE FOR RHO TO USE AS IT SEES FIT. THEY ARE PASSED C TO RHO WITHOUT CHANGE. IF IV(RDREQ) IS AT LEAST 4, I.E., IF MORE C THAN THE SIMPLEST REGRESSION DIAGNOSTIC INFORMATION IS TO BE COMPUTED, C THEN SOME COMPONENTS OF RHOI AND RHOR MUST CONVEY SOME EXTRA C DETAILS, AS DESCRIBED BELOW. C F, R, RD, AND W ARE EXPLAINED BELOW WITH NEED. C XN IS THE VECTOR OF NUISANCE PARAMETERS (OF LENGTH P - PS). IF C RHO NEEDS TO KNOW THE LENGTH OF XN, THEN THIS LENGTH SHOULD BE C COMMUNICATED THROUGH RHOI (OR THROUGH COMMON). RHO SHOULD NOT CHANGE C XN. C NEED(1) = 1 MEANS RHO SHOULD SET F TO THE SUM OF THE LOSS FUNCTION C VALUES AT THE RESIDUALS R(I). NF IS THE CURRENT FUNCTION INVOCATION C COUNT (A VALUE THAT IS INCREMENTED EACH TIME A NEW PARAMETER EXTIMATE C X IS CONSIDERED). NEED(2) IS THE VALUE NF HAD AT THE LAST R WHERE C RHO MIGHT BE CALLED WITH NEED(1) = 2. IF RHO SAVES INTERMEDIATE C RESULTS FOR USE IN CALLS WITH NEED(1) = 2, THEN IT CAN USE NF TO TELL C WHICH INTERMEDIATE RESULTS ARE APPROPRIATE, AND IT CAN SAVE SOME OF C THESE RESULTS IN R. C NEED(1) = 2 MEANS RHO SHOULD SET R(I) TO THE LOSS FUNCTION C DERIVATIVE WITH RESPECT TO THE RESIDUALS THAT WERE PASSED TO RHO WHEN C NF HAD THE SAME VALUE IT DOES NOW (AND NEED(1) WAS 1). RHO SHOULD C ALSO SET W(I) TO THE APPROXIMATION OF THE SECOND DERIVATIVE OF THE C LOSS FUNCTION (WITH RESPECT TO THE I-TH RESIDUAL) THAT SHOULD BE USED C IN THE GAUSS-NEWTON MODEL. WHEN THERE ARE NUISANCE PARAMETERS (I.E., C WHEN PS .LT. P) RHO SHOULD ALSO SET R(I+K*N) TO THE DERIVATIVE OF THE C LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL AND XN(K), AND IT C SHOULD SET RD(I,J + K*(K+1)/2 + 1) TO THE SECOND PARTIAL DERIVATIVE C OF THE I-TH RESIDUAL WITH RESPECT TO XN(J) AND XN(K), 0 .LE. J .LE. K C AND 1 .LE. K .LE. P - PS, WHERE XN(0) MEANS THE I-TH RESIDUAL ITSELF. C IN ANY EVENT, RHO SHOULD ALSO SET RD(I,1) TO THE (TRUE) SECOND C DERIVATIVE OF THE LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL. C NF (THE FUNCTION INVOCATION COUNT WHOSE NORMAL USE IS EXPLAINED C ABOVE) SHOULD NOT BE CHANGED UNLESS RHO CANNOT CARRY OUT THE REQUESTED C TASK, IN WHICH CASE RHO SHOULD SET NF TO 0. C C C *** REGRESSION DIAGNOSTICS *** C C IV(RDREQ) INDICATES WHETHER A COVARIANCE MATRIX AND REGRESSION C DIAGNOSTIC VECTOR ARE TO BE COMPUTED. IV(RDREQ) HAS THE FORM C IV(RDREQ) = CVR +2*RDR, WHERE CVR = 0 OR 1 AND RDR = 0, 1, OR 2, C SO THAT C C CVR = MOD(IV(RDREQ), 2) C RDR = MOD(IV(RDREQ)/2, 3). C C CVR = 0 FOR NO COVARIANCE MATRIX C = 1 IF A COVARIANCE MATRIX ESTIMATE IS DESIRED C C RDR = 0 FOR NO LEAVE-ONE-OUT DIAGNOSTIC INFORMATION. C = 1 TO HAVE ONE-STEP ESTIMATES OF F(X(I)) - F(X*) STORED IN RD, C WHERE X(I) MINIMIZES F (THE OBJECTIVE FUNCTION) WITH C COMPONENT I OF R REMOVED AND X* MINIMIZES THE FULL F. C = 2 FOR MORE DETAILED ONE-STEP LEAVE-ONE-OUT INFORMATION, AS C DICTATED BY THE IV COMPONENTS DESCRIBED BELOW. C C FOR RDR = 2, THE FOLLOWING COMPONENTS OF IV ARE RELEVANT... C C NFIX = IV(83) = NUMBER OF TRAILING NUISANCE PARAMETERS TO TREAT C AS FIXED WHEN COMPUTING DIAGNOSTIC VECTORS (0 .LE. NFIX .LE. C P - PS, SO X(I) IS KEPT FIXED FOR P - NFIX .LT. I .LE. P). C C LOO = IV(84) TELLS WHAT TO LEAVE OUT... C = 1 MEANS LEAVE OUT EACH COMPONENT OF R SEPARATELY, AND C = 2 MEANS LEAVE OUT CONTIGUOUS BLOCKS OF R COMPONENTS. C FOR LOO = 2, IV(85) IS THE STARTING SUBSCRIPT IN RHOI C OF AN ARRAY BS OF BLOCK SIZES, IV(86) IS THE STRIDE FOR BS, C AND IV(87) = NB IS THE NUMBER OF BLOCKS, SO THAT C BS(I) = RHOI(IV(85) + (I-1)*IV(86)), 1 .LE. I .LE. NB. C NOTE THAT IF ALL BLOCKS ARE THE SAME SIZE, THEN IT SUFFICES C TO SET RHOI(IV(85)) = BLOCKSIZE AND IV(86) = 0. C NOTE THAT LOO = 1 IS EQUIVALENT TO LOO = 2 WITH C RHOI(IV(85)) = 1, IV(86) = 0, IV(87) = N. C = 3,4 ARE SIMILAR TO LOO = 1,2, RESPECTIVELY, BUT LEAVING A C FRACTION OUT. IN THIS CASE, IV(88) IS THE STARTING C SUBSCRIPT IN RHOR OF AN ARRAY FLO OF FRACTIONS TO LEAVE OUT, C AND IV(89) IS THE STRIDE FOR FLO... C FLO(I) = RHOR(IV(88) + (I-1)*IV(89)), 1 .LE. I .LE. NB. C C XNOTI = IV(90) TELLS WHAT DIAGNOSTIC INFORMATION TO STORE... C = 0 MEANS JUST STORE ONE-STEP ESTIMATES OF F(X(I)) - F(X*) IN C RD(I), 1 .LE. I .LE. NB. C .GT. 0 MEANS ALSO STORE ONE-STEP ESTIMATES OF X(I) ESTIMATES C IN RHOR, STARTING AT RHOR(XNOTI)... C X(I)(J) = RHOR((I-1)*(P-NFIX) + J + XNOTI-1), C 1 .LE. I .LE. NB, 1 .LE. J .LE. P - NFIX. C C SOMETIMES ONE-STEP ESTIMATES OF X(I) DO NOT EXIST, BECAUSE THE C APPROXIMATE UPDATED HESSIAN MATRIX IS INDEFINITE. IN SUCH CASES, C THE CORRESPONDING RD COMPONENT IS SET TO -1, AND, IF XNOTI IS C POSITIVE, THE SOLUTION X IS RETURNED AS X(I). WHEN ONE-STEP ESTIMATES C OF X(I) DO EXIST, THE CORRESPONDING COMPONENT OF RD IS POSITIVE. C C SUMMARY OF RHOI COMPONENTS (FOR RDR = MOD(IV(RDREQ)/2, 3) = 2)... C C IV(83) = NFIX C IV(84) = LOO C IV(85) = START IN RHOI OF BS C IV(86) = STRIDE FOR BS C IV(87) = NB C IV(88) = START IN RHOR OF FLO C IV(89) = STRIDE FOR FLO C IV(90) = XNOTI (START IN RHOR OF X(I)). C C C *** COVARIANCE MATRIX ESTIMATE *** C C IF IV(RDREQ) INDICATES THAT A COVARIANCE MATRIX IS TO BE COMPUTED, C THEN IV(COVREQ) = IV(15) DETERMINES THE FORM OF THE COMPUTED C COVARIANCE MATRIX ESTIMATE AND, SIMULTANEOUSLY, THE FORM OF C APPROXIMATE HESSIAN MATRIX USED IN COMPUTING REGRESSION DIAGNOSTIC C INFORMATION. IN ALL CASES, SOME APPROXIMATE FINAL HESSIAN MATRIX C IS OBTAINED, AND ITS INVERSE IS THE COVARIANCE MATRIX ESTIMATE C (WHICH MAY HAVE TO BE SCALED APPROPRIATELY -- THAT IS UP TO YOU). C IF IV(COVREQ) IS AT MOST 2 IN ABSOLUTE VALUE, THEN THE FINAL C HESSIAN APPROXIMATION IS COMPUTED BY FINITE DIFFERENCES -- GRADIENT C DIFFERENCES IF IV(COVREQ) IS NONNEGATIVE, FUNCTION DIFFERENCES C OTHERWISE. IF (IV(COVREQ)) IS AT LEAST 3 IN ABSOLUTE VALUE, THEN THE C CURRENT GAUSS-NEWTON HESSIAN APPROXIMATION IS TAKEN AS THE FINAL C HESSIAN APPROXIMATION. FOR SOME PROBLEMS THIS SAVES TIME AND YIELDS C THE SAME OR NEARLY THE SAME HESSIAN APPROXIMATION AS DO FINITE C DIFFERENCES. FOR OTHER PROBLEMS, THE TWO KINDS OF HESSIAN C APPROXIMATIONS MAY GIVE DECIDEDLY DIFFERENT REGRESSION DIAGNOSTICS AND C COVARIANCE MATRIX ESTIMATES. C C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DD7UP5,DIVSET, DG2LRD, DN3RDP, DD7TPR, DQ7ADR, DVSUM, 1 DG7LIT,DITSUM, DL7NVR, DL7ITV, DL7IVM,DL7SRT, DL7SQR, 2 DL7SVX, DL7SVN, DL7TSQ,DL7VML,DO7PRD,DV2AXY,DV7CPY, 3 DV7SCL, DV7SCP DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN,DVSUM C C DD7UP5... UPDATES SCALE VECTOR D. C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DG2LRD.... COMPUTES REGRESSION DIAGNOSTIC. C DN3RDP... PRINTS REGRESSION DIAGNOSTIC. C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C DQ7ADR.... ADDS ROWS TO QR FACTORIZATION. C DVSUM..... RETURNS SUM OF ELEMENTS OF A VECTOR. C DG7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM. C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C DL7NVR... INVERTS COMPACTLY STORED TRIANGULAR MATRIX. C DL7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C DL7IVM... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C DL7SQR... COMPUTES L*(L**T) FOR LOWER TRIANG. MATRIX L. C DL7SVX... UNDERESTIMATES LARGEST SINGULAR VALUE OF TRIANG. MATRIX. C DL7SVN... OVERESTIMATES SMALLEST SINGULAR VALUE OF TRIANG. MATRIX. C DL7TSQ... COMPUTES (L**T)*L FOR LOWER TRIANG. MATRIX L. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DO7PRD.... ADDS OUTER PRODUCT OF VECTORS TO A MATRIX. C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCL... MULTIPLIES A VECTOR BY A SCALAR. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C LOGICAL JUSTG, UPDATD, ZEROG INTEGER G1, HN1, I, II, IV1, J, J1, JTOL1, K, L, LH, 1 NEED1(2), NEED2(2), PMPS, PS1, PSLEN, QTR1, 2 RMAT1, STEP1, TEMP1, TEMP2, TEMP3, TEMP4, W, WI, Y1 DOUBLE PRECISION RHMAX, RHTOL, RHO1, RHO2, T C DOUBLE PRECISION ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COVMAT, DINIT, DTYPE, DTINIT, D0INIT, F, 1 F0, FDH, G, H, HC, IPIVOT, IVNEED, JCN, JTOL, LMAT, 2 MODE, NEXTIV, NEXTV, NF0, NF1, NFCALL, NFCOV, NFGCAL, 3 NGCALL, NGCOV, PERM, QTR, RDREQ, REGD, RESTOR, 4 RMAT, RSPTOL, STEP, TOOBIG, VNEED, XNOTI, Y C C *** IV SUBSCRIPT VALUES *** C PARAMETER (CNVCOD=55, COVMAT=26, DTYPE=16, F0=13, FDH=74, G=28, 1 H=56, HC=71, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59, 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6, 3 NFCOV=52, NF0=68, NF1=69, NFGCAL=7, NGCALL=30, 4 NGCOV=53, PERM=58, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, 5 REGD=67, STEP=40, TOOBIG=2, VNEED=4, XNOTI=90, Y=48) C C *** V SUBSCRIPT VALUES *** C PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RSPTOL=49) PARAMETER (ONE=1.D+0, ZERO=0.D+0) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) PS1 = PS + 1 IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 W = IV(Y) + P IV(RESTOR) = 0 I = IV1 + 2 IF (IV(TOOBIG) .EQ. 0) GO TO (120, 110, 110, 130), I V(F) = V(F0) IF (I .NE. 3) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LT. PS) GO TO 360 IF (PS .GT. P) GO TO 360 IF (PS .LE. 0) GO TO 360 IF (N .LE. 0) GO TO 360 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 420 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 + 2*N + 4*PS C *** ADJUST IV(PERM) TO MAKE ROOM FOR IV INPUT COMPONENTS C *** NEEDED WHEN IV(RDREQ) IS 4 OR 5... I = XNOTI + 1 IF (IV(PERM) .LT. I) IV(PERM) = I C 20 CALL DG7LIT(D, X, IV, LIV, LV, P, PS, 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 + N IV(RMAT) = IV(G) + P + 4*PS IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + P + N IV(JCN) = IV(JTOL) + 2*P IV(NEXTV) = IV(JCN) + 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 C 40 G1 = IV(G) Y1 = IV(Y) CALL DG7LIT(D, V(G1), IV, LIV, LV, P, PS, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 380 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 999 IF (IV(RESTOR) .NE. 2) GO TO 999 IV(NF0) = IV(NF1) CALL DV7CPY(N, RD, R) IV(REGD) = 0 GO TO 999 C 60 IF (IV(MODE) .GT. 0) GO TO 370 CALL DV7SCP(P, V(G1), ZERO) RMAT1 = IABS(IV(RMAT)) QTR1 = IABS(IV(QTR)) CALL DV7SCP(PS, V(QTR1), ZERO) IV(REGD) = 0 CALL DV7SCP(PS, V(Y1), ZERO) CALL DV7SCP(LH, V(RMAT1), ZERO) IF (IV(RESTOR) .NE. 3) GO TO 70 CALL DV7CPY(N, R, RD) IV(NF1) = IV(NF0) 70 CALL RHO(NEED2, T, N, IV(NFGCAL), X(PS1), R, RD, RHOI, RHOR, V(W)) IF (IV(NFGCAL) .GT. 0) GO TO 90 80 IV(TOOBIG) = 1 GO TO 40 90 IF (IV(MODE) .LT. 0) GO TO 999 DO 100 I = 1, N 100 CALL DV2AXY(PS, V(Y1), R(I), DR(1,I), V(Y1)) GO TO 999 C C *** COMPUTE F(X) *** C 110 I = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL RHO(NEED1, V(F), N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IV(NF1) = I IF (I .LE. 0) GO TO 80 GO TO 40 C C *** COMPUTE GRADIENT INFORMATION FOR FINITE-DIFFERENCE HESSIAN *** C 120 IV(1) = 2 JUSTG = .TRUE. I = IV(NFCALL) CALL RHO(NEED1, T, N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IF (I .LE. 0) GO TO 80 CALL RHO(NEED2, T, N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IF (I .LE. 0) GO TO 80 GO TO 250 C C *** PREPARE TO COMPUTE GRADIENT INFORMATION WHILE ITERATING *** C 130 JUSTG = .FALSE. G1 = IV(G) C C *** DECIDE WHETHER TO UPDATE D BELOW *** C I = IV(DTYPE) UPDATD = .FALSE. IF (I .LE. 0) GO TO 140 IF (I .EQ. 1 .OR. IV(MODE) .LT. 0) UPDATD = .TRUE. C C *** COMPUTE RMAT AND QTR *** C 140 QTR1 = IABS(IV(QTR)) RMAT1 = IABS(IV(RMAT)) IV(RMAT) = RMAT1 IV(HC) = 0 IV(NF0) = 0 IV(NF1) = 0 IF (IV(MODE) .LT. 0) GO TO 160 C C *** ADJUST Y *** C Y1 = IV(Y) WI = W STEP1 = IV(STEP) DO 150 I = 1, N T = V(WI) - RD(I) WI = WI + 1 IF (T .NE. ZERO) CALL DV2AXY(PS, V(Y1), 1 T*DD7TPR(PS,V(STEP1),DR(1,I)), DR(1,I), V(Y1)) 150 CONTINUE C C *** CHECK FOR NEGATIVE W COMPONENTS *** C 160 J1 = W + N - 1 DO 170 WI = W, J1 IF (V(WI) .LT. ZERO) GO TO 240 170 CONTINUE C C *** W IS NONNEGATIVE. COMPUTE QR FACTORIZATION *** C *** AND, IF NECESSARY, USE SEMINORMAL EQUATIONS *** C RHMAX = ZERO RHTOL = V(RSPTOL) TEMP1 = G1 + P ZEROG = .TRUE. WI = W DO 200 I = 1, N RHO1 = R(I) RHO2 = V(WI) WI = WI + 1 T = SQRT(RHO2) IF (RHMAX .LT. RHO2) RHMAX = RHO2 IF (RHO2 .GT. RHTOL*RHMAX) GO TO 180 C *** SEMINORMAL EQUATIONS *** CALL DV2AXY(PS, V(G1), RHO1, DR(1,I), V(G1)) RHO1 = ZERO ZEROG = .FALSE. GO TO 190 180 RHO1 = RHO1 / T C *** QR ACCUMULATION *** 190 CALL DV7SCL(PS, V(TEMP1), T, DR(1,I)) CALL DQ7ADR(PS, V(QTR1), V(RMAT1), V(TEMP1), RHO1) 200 CONTINUE C C *** COMPUTE G FROM RMAT AND QTR *** C TEMP2 = TEMP1 + PS CALL DL7VML(PS, V(TEMP1), V(RMAT1), V(QTR1)) IF (ZEROG) GO TO 220 IV(QTR) = -QTR1 IF (DL7SVX(PS, V(RMAT1), V(TEMP2), V(TEMP2)) * RHTOL .GE. 1 DL7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2))) GO TO 230 CALL DL7IVM(PS, V(TEMP2), V(RMAT1), V(G1)) C C *** SEMINORMAL EQUATIONS CORRECTION OF BJOERCK -- C *** ONE CYCLE OF ITERATIVE REFINEMENT... C TEMP3 = TEMP2 + PS TEMP4 = TEMP3 + PS CALL DL7ITV(PS, V(TEMP3), V(RMAT1), V(TEMP2)) CALL DV7SCP(PS, V(TEMP4), ZERO) RHMAX = ZERO WI = W DO 210 I = 1, N RHO2 = V(WI) WI = WI + 1 IF (RHMAX .LT. RHO2) RHMAX = RHO2 RHO1 = ZERO IF (RHO2 .LE. RHTOL*RHMAX) RHO1 = R(I) T = RHO1 - RHO2*DD7TPR(PS, V(TEMP3), DR(1,I)) CALL DV2AXY(PS, V(TEMP4), T, DR(1,I), V(TEMP4)) 210 CONTINUE CALL DL7IVM(PS, V(TEMP3), V(RMAT1), V(TEMP4)) CALL DV2AXY(PS, V(TEMP2), ONE, V(TEMP3), V(TEMP2)) CALL DV2AXY(PS, V(QTR1), ONE, V(TEMP2), V(QTR1)) 220 IV(QTR) = QTR1 230 CALL DV2AXY(PS, V(G1), ONE, V(TEMP1), V(G1)) IF (PS .GE. P) GO TO 350 GO TO 270 C C *** INDEFINITE GN HESSIAN... *** C 240 IV(RMAT) = -RMAT1 IV(HC) = RMAT1 CALL DO7PRD(N, LH, PS, V(RMAT1), V(W), DR, DR) C C *** COMPUTE GRADIENT *** C 250 G1 = IV(G) CALL DV7SCP(P, V(G1), ZERO) DO 260 I = 1, N 260 CALL DV2AXY(PS, V(G1), R(I), DR(1,I), V(G1)) IF (PS .GE. P) GO TO 350 C C *** COMPUTE GRADIENT COMPONENTS OF NUISANCE PARAMETERS *** C 270 K = P - PS J1 = 1 G1 = G1 + PS DO 280 J = 1, K J1 = J1 + NN V(G1) =DVSUM(N, R(J1)) G1 = G1 + 1 280 CONTINUE IF (JUSTG) GO TO 390 C C *** COMPUTE HESSIAN COMPONENTS OF NUISANCE PARAMETERS *** C I = PS*PS1/2 PSLEN = P*(P+1)/2 - I HN1 = RMAT1 + I CALL DV7SCP(PSLEN, V(HN1), ZERO) PMPS = P - PS K = HN1 J1 = 1 DO 310 II = 1, PMPS J1 = J1 + NN J = J1 DO 290 I = 1, N CALL DV2AXY(PS, V(K), RD(J), DR(1,I), V(K)) J = J + 1 290 CONTINUE K = K + PS DO 300 I = 1, II J1 = J1 + NN V(K) =DVSUM(N, RD(J1)) K = K + 1 300 CONTINUE 310 CONTINUE IF (IV(RMAT) .LE. 0) GO TO 350 J = IV(LMAT) CALL DV7CPY(PSLEN, V(J), V(HN1)) IF (DL7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2)) .LE. ZERO) GO TO 320 CALL DL7SRT(PS1, P, V(RMAT1), V(RMAT1), I) IF (I .LE. 0) GO TO 330 C C *** HESSIAN IS NOT POSITIVE DEFINITE *** C 320 CALL DL7SQR(PS, V(RMAT1), V(RMAT1)) CALL DV7CPY(PSLEN, V(HN1), V(J)) IV(HC) = RMAT1 IV(RMAT) = -RMAT1 GO TO 350 C C *** NUISANCE PARS LEAVE HESSIAN POS. DEF. GET REST OF QTR *** C 330 J = QTR1 + PS G1 = IV(G) + PS DO 340 I = PS1, P T = DD7TPR(I-1, V(HN1), V(QTR1)) HN1 = HN1 + I V(J) = (V(G1) - T) / V(HN1-1) J = J + 1 G1 = G1 + 1 340 CONTINUE 350 IF (JUSTG) GO TO 390 IF (UPDATD) CALL DD7UP5(D, IV, LIV, LV, P, PS, V) GO TO 40 C C *** MISC. DETAILS *** C C *** BAD N, ND, OR P *** C 360 IV(1) = 66 GO TO 420 C C *** COVARIANCE OR INITIAL S COMPUTATION *** C 370 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 GO TO 999 C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 380 IF (IV(COVMAT) .NE. 0) GO TO 410 IF (IV(REGD) .NE. 0) GO TO 410 C C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE *** C K = IV(FDH) IF (K .LE. 0) GO TO 400 IF (IV(RDREQ) .LE. 0) GO TO 410 C C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF C DESIRED *** C IV(MODE) = P + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 IV(CNVCOD) = IV(1) IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 GO TO 999 C 390 IF (IV(MODE) .LE. P) GO TO 40 C *** SAVE RD IN W FOR POSSIBLE USE IN OTHER DIAGNOSTICS *** CALL DV7CPY(N, V(W), RD) C *** OVERWRITE RD WITH REGRESSION DIAGNOSTICS *** L = IV(LMAT) I = IV(JCN) STEP1 = IV(STEP) CALL DG2LRD(DR, IV, V(L), LH, LIV, LV, ND, N, P, PS, R, RD, 1 RHOI, RHOR, V, V(STEP1), X, V(I)) IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 IF (MOD(IV(RDREQ),2) .EQ. 0) GO TO 410 C C *** FINISH COVARIANCE COMPUTATION *** C I = IABS(IV(H)) IV(FDH) = 0 CALL DL7NVR(P, V(I), V(L)) CALL DL7TSQ(P, V(I), V(I)) IV(COVMAT) = I GO TO 410 C C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN *** C 400 IV(COVMAT) = K IV(REGD) = K C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 410 G1 = IV(G) 420 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X) IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0) 1 CALL DN3RDP(IV, LIV, LV, N, P, RD, RHOI, RHOR, V) C 999 RETURN C *** LAST LINE OF DRGLG 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) * MAX(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 100 X(M) = X(M) + DEL V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 110 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 120 C *** FIRST CALL ON 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) * MAX(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** RESTORE V(F), ETC. *** C 210 IV(FDH) = HES 220 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL DV7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST LINE OF DF7HES FOLLOWS *** END SUBROUTINE DG2LRD(DR, IV, L, LH, LIV, LV, ND, N, P, PS, R, RD, 1 RHOI, RHOR, V, W, X, Z) C C *** COMPUTE REGRESSION DIAGNOSTIC FOR DRGLG *** C C *** PARAMETERS *** C INTEGER LH, LIV, LV, ND, N, P, PS INTEGER IV(LIV), RHOI(*) DOUBLE PRECISION DR(ND,P), L(LH), R(N), RD(N), RHOR(*), V(LV), 1 W(P), X(P), Z(P) C C *** CODED BY DAVID M. GAY (SPRING 1986, SUMMER 1991) *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DD7TPR, DL7ITV, DL7IVM,DL7SRT, DL7SQR, DS7LVM, 1 DV2AXY,DV7CPY, DV7SCP DOUBLE PRECISION DD7TPR C C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C DL7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C DL7IVM... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C DL7SQR... COMPUTES L*(L**T) FOR LOWER TRIANG. MATRIX L. C DS7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR. C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C LOGICAL USEFLO INTEGER BS1, BSINC, FLO1, FLOINC, H1, HPS1, I, 1 J, J1, K, KI, KI1, KID, L1, LE, LL, LOO1, N1, 2 PMPS, PP1O2, PS1, PX, RDR, XNI, ZAP1, ZAPLEN DOUBLE PRECISION FRAC, HI, RI, S, T, T1 C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ZERO C C C *** IV SUBSCRIPTS *** C INTEGER BS, BSSTR, COVREQ, FDH, FLO, FLOSTR, LOO, NB, NFIX, 1 RDREQ, REGD, XNOTI PARAMETER (BS=85, BSSTR=86, COVREQ=15, FDH=74, FLO=88, FLOSTR=89, 1 LOO=84, NB=87, NFIX=83, RDREQ=57, REGD=67, XNOTI=90) PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0) C C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++ C I = IV(RDREQ) RDR = MOD(I/2, 3) IF (RDR .EQ. 0) GO TO 999 H1 = IV(FDH) USEFLO = .FALSE. PX = P N1 = N FRAC = ONE XNI = 0 IF (RDR .EQ. 1) GO TO 120 LOO1 = IV(LOO) IF (LOO1 .LE. 0 .OR. LOO1 .GT. 6) THEN IV(REGD) = -1 GO TO 999 ENDIF IF (LOO1 .GT. 3) THEN USEFLO = .TRUE. FLO1 = IV(FLO) FLOINC = IV(FLOSTR) LOO1 = LOO1 - 3 ENDIF XNI = IV(XNOTI) PX = P - IV(NFIX) IF (PX .LT. PS .OR. PX .GT. P) THEN IV(REGD) = -2 GO TO 999 ENDIF IF (LOO1 .EQ. 1) GO TO 120 N1 = IV(NB) IF (N1 .LE. 0 .OR. N1 .GT. N) THEN IV(REGD) = -3 GO TO 999 ENDIF BS1 = IV(BS) BSINC = IV(BSSTR) IF (H1 .LE. 0) GO TO 190 IF (IABS(IV(COVREQ)) .GE. 3) CALL DL7SQR(P, V(H1), L) PP1O2 = PX*(PX+1)/2 PS1 = PS + 1 ZAP1 = PS*(PS1)/2 + 1 LE = 0 DO 100 I = 1, N1 IF (USEFLO) THEN FRAC = RHOR(FLO1) FLO1 = FLO1 + FLOINC ENDIF L1 = LE + 1 IF (L1 .GT. N) GO TO 110 LE = LE + RHOI(BS1) IF (LE .GT. N) LE = N BS1 = BS1 + BSINC CALL DV7CPY(PP1O2, L, V(H1)) IF (PS .GE. PX) GO TO 50 K = ZAP1 KI = L1 DO 40 J = PS1, P KI = KI + N KI1 = KI DO 10 LL = L1, LE CALL DV2AXY(PS, L(K), -FRAC*RD(KI1), DR(1,LL), L(K)) KI1 = KI1 + 1 10 CONTINUE K = K + PS DO 30 J1 = PS1, J KI = KI + N KI1 = KI T = ZERO DO 20 LL = L1, LE T = T + RD(KI1) KI1 = KI1 + 1 20 CONTINUE L(K) = L(K) - FRAC*T K = K + 1 30 CONTINUE 40 CONTINUE 50 DO 70 LL = L1, LE T = -FRAC*RD(LL) K = 1 DO 60 J = 1, PS CALL DV2AXY(J, L(K), T*DR(J,LL), DR(1,LL), L(K)) K = K + J 60 CONTINUE 70 CONTINUE CALL DL7SRT(1, PX, L, L, J) IF (J .EQ. 0) THEN CALL DV7SCP(PX, W, ZERO) DO 90 LL = L1, LE CALL DV2AXY(PS, W, R(LL), DR(1,LL), W) IF (PS1 .GT. PX) GO TO 90 K = L1 DO 80 J = PS1, P K = K + N W(J) = W(J) + R(K) 80 CONTINUE 90 CONTINUE CALL DL7IVM(PX, W, L, W) CALL DL7ITV(PX, W, L, W) CALL DS7LVM(PX, Z, V(H1), W) RD(I) = HALF * FRAC * DD7TPR(PX, W, Z) IF (XNI .GT. 0) THEN CALL DV2AXY(PX, RHOR(XNI), FRAC, W, X) XNI = XNI + PX ENDIF ELSE RD(I) = NEGONE IF (XNI .GT. 0) THEN CALL DV7CPY(PX, RHOR(XNI), X) XNI = XNI + PX ENDIF ENDIF 100 CONTINUE 110 IV(REGD) = 1 C *** RESTORE L *** CALL DL7SRT(1, P, L, V(H1), J) GO TO 999 C 120 IF (H1 .LE. 0) GO TO 190 IF (IABS(IV(COVREQ)) .GE. 3) CALL DL7SQR(P, V(H1), L) IF (PS .GE. PX) GO TO 170 PS1 = PS + 1 PMPS = PX - PS ZAP1 = PS*(PS1)/2 ZAPLEN = PX*(PX+1)/2 - ZAP1 HPS1 = H1 + ZAP1 ZAP1 = ZAP1 + 1 DO 160 I = 1, N IF (USEFLO) THEN FRAC = RHOR(FLO1) FLO1 = FLO1 + FLOINC ENDIF CALL DV7CPY(ZAPLEN, L(ZAP1), V(HPS1)) CALL DV7SCP(PS, W, ZERO) K = ZAP1 KI = I KID = KI DO 140 J = PS1, PX KI = KI + N CALL DV2AXY(PS, L(K), -FRAC*RD(KI), DR(1,I), L(K)) K = K + PS KID = KID + N W(J) = FRAC*R(KID) DO 130 J1 = PS1, J KI = KI + N L(K) = L(K) - FRAC*RD(KI) K = K + 1 130 CONTINUE 140 CONTINUE CALL DL7SRT(PS1, PX, L, L, J) IF (J .NE. 0) GO TO 150 CALL DV7CPY(PS, Z, DR(1,I)) CALL DV7SCP(PMPS, Z(PS1), ZERO) CALL DL7IVM(PX, Z, L, Z) HI = DD7TPR(PX, Z, Z) CALL DL7IVM(PX, W, L, W) RI = FRAC*R(I) C *** FIRST PS ELEMENTS OF W VANISH *** T = DD7TPR(PMPS, W(PS1), Z(PS1)) S = FRAC*RD(I) T1 = ONE - S*HI IF (T1 .LE. ZERO) GO TO 150 CALL DV2AXY(PX, W, (RI + S*T)/T1, Z, W) CALL DL7ITV(PX, W, L, W) CALL DS7LVM(PX, Z, V(H1), W) RD(I) = HALF * DD7TPR(PX, W, Z) IF (XNI .GT. 0) THEN CALL DV2AXY(PX, RHOR(XNI), ONE, W, X) XNI = XNI + PX ENDIF GO TO 160 150 RD(I) = NEGONE IF (XNI .GT. 0) THEN CALL DV7CPY(PX, RHOR(XNI), X) XNI = XNI + PX ENDIF 160 CONTINUE C C *** RESTORE L *** C CALL DV7CPY(ZAPLEN, L(ZAP1), V(HPS1)) CALL DL7SRT(PS1, PX, L, L, J) GO TO 200 C 170 DO 180 I = 1, N IF (USEFLO) THEN FRAC = RHOR(FLO1) FLO1 = FLO1 + FLOINC ENDIF CALL DL7IVM(PX, Z, L, DR(1,I)) S = DD7TPR(PX, Z, Z) T = ONE - FRAC*RD(I) * S IF (T .LE. ZERO) THEN RD(I) = NEGONE IF (XNI .GT. 0) THEN CALL DV7CPY(PX, RHOR(XNI), X) XNI = XNI + PX ENDIF ELSE RD(I) = HALF * FRAC * (R(I)/T)**2 * S IF (XNI .GT. 0) THEN CALL DL7ITV(PX, Z, L, Z) CALL DV2AXY(PX, RHOR(XNI), FRAC*R(I)/T, Z, X) XNI = XNI + PX ENDIF ENDIF 180 CONTINUE GO TO 200 C 190 CALL DV7SCP(N1, RD, NEGONE) 200 IV(REGD) = 1 C 999 RETURN C *** LAST LINE OF DG2LRD FOLLOWS *** END SUBROUTINE DG7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) DOUBLE PRECISION D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 82. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C DG7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND DG7LIT BUILDS AN C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD C VECTOR USED IN UPDATING S. DG7LIT DECIDES DYNAMICALLY WHETHER OR C NOT TO USE S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR C HC + S (AUGMENTED MODEL). C C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S,DG7LIT ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7LIT WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY DG7LIT OR THE SUBROUTINES IT CALLS. C C WHEN DG7LIT IS FIRST CALLED, I.E., WHEN DG7LIT IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES,DG7LIT RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7LIT WILL MAKE A C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL DG7LIT AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE DG7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME DG7LIT RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL DG7LIT AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(TOOBIG) TO 1, IN WHICH CASE DG7LIT WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1, 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, 2 TEMP1, TEMP2, W1, X01 DOUBLE PRECISION E, STTSST, T, T1 C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DRLDST, DR7MDC, DV2NRM EXTERNAL DA7SST, DD7TPR,DF7HES,DG7QTS,DITSUM, DL7MST,DL7SRT, 1 DL7SQR, DL7SVX, DL7SVN, DL7TVM,DL7VML,DPARCK, DRLDST, 2 DR7MDC, DS7LUP, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP, 3 DV2NRM C C DA7SST.... ASSESSES CANDIDATE STEP. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DF7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE). C DG7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DL7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F, 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS, 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL, 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV, 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR, 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED, 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE, 8 XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C 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 GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I C C *** STORAGE ALLOCATION *** C 10 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(W) = IV(DIG) + P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(RESTOR) = 0 IV(FDH) = 0 V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(S) .LT. 0) GO TO 999 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO) IV(1) = 1 J = IV(IPIVOT) IF (J .LE. 0) GO TO 999 DO 30 I = 1, P IV(J) = I J = J + 1 30 CONTINUE GO TO 999 C C *** NEW FUNCTION VALUE *** C 40 IF (IV(MODE) .EQ. 0) GO TO 290 IF (IV(MODE) .GT. 0) GO TO 520 C IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 999 C C *** NEW GRADIENT *** C 50 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 520 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 65 GO TO 999 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610 C C *** COMPUTE D**-1 * GRADIENT *** C DIG1 = IV(DIG) K = DIG1 DO 70 I = 1, P V(K) = G(I) / D(I) K = K + 1 70 CONTINUE V(DGNORM) = DV2NRM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 510 IF (IV(MODE) .EQ. 0) GO TO 440 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 100 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 530 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 80 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 90 CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 100 90 RMAT1 = IV(RMAT) CALL DL7SQR(PS, V(S1), V(RMAT1)) CALL DV2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1)) 100 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 110 CALL DITSUM(D, G, IV, LIV, LV, P, V, X) 120 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 130 IV(1) = 10 GO TO 999 130 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 150 STEP1 = IV(STEP) DO 140 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 140 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * DV2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 150 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL DV7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 160 IF (.NOT. STOPX(DUMMY)) GO TO 180 IV(1) = 11 GO TO 190 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 170 IF (V(F) .GE. V(F0)) GO TO 180 V(RADFAC) = ONE K = IV(NITER) GO TO 130 C 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200 IV(1) = 9 190 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 430 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 200 STEP1 = IV(STEP) W1 = IV(W) H1 = IV(H) T1 = ONE IF (IV(MODEL) .EQ. 2) GO TO 210 T1 = ZERO C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 210 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 210 IPIV1 = IV(IPIVOT) CALL DL7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1), 1 V(RMAT1), V(STEP1), V, V(W1)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 260 C 210 IF (H1 .GT. 0) GO TO 250 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C H1 = -H1 IV(H) = H1 IV(FDH) = 0 J = IV(HC) IF (J .GT. 0) GO TO 220 J = H1 RMAT1 = IV(RMAT) CALL DL7SQR(P, V(H1), V(RMAT1)) 220 S1 = IV(S) DO 240 I = 1, P T = ONE / D(I) DO 230 K = 1, I V(H1) = T * (V(J) + T1*V(S1)) / D(K) J = J + 1 H1 = H1 + 1 S1 = S1 + 1 230 CONTINUE 240 CONTINUE H1 = IV(H) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 250 DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL DG7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), 1 V, V(W1)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 260 IF (IV(IRC) .NE. 6) GO TO 270 IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 2 GO TO 300 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 270 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 290 IF (IV(IRC) .NE. 5) GO TO 280 IF (V(RADFAC) .LE. ONE) GO TO 280 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280 IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 0 GO TO 300 C C *** COMPUTE F(X0 + STEP) *** C 280 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 290 RSTRST = 3 300 X01 = IV(X0) V(RELDX) = DRLDST(P, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (340, 310, 320, 330), I 310 CALL DV7CPY(P, X, V(X01)) GO TO 340 320 CALL DV7CPY(P, V(LSTGST), V(STEP1)) GO TO 340 330 CALL DV7CPY(P, V(STEP1), V(LSTGST)) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = DRLDST(P, D, X, V(X01)) IV(RESTOR) = RSTRST C C *** IF NECESSARY, SWITCH MODELS *** C 340 IF (IV(SWITCH) .EQ. 0) GO TO 350 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL DV7CPY(NVSAVE, V, V(L)) 350 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL DS7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * DD7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 360 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 400 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL 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 = ABS(DD7TPR(PS, V(STEP1), V(TEMP1))) T = ABS(DD7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 490 C 480 RMAT1 = IV(RMAT) CALL DL7TVM(PS, V(G01), V(RMAT1), V(STEP1)) CALL DL7VML(PS, V(G01), V(RMAT1), V(G01)) C 490 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 110 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 500 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 510 IF (IV(RDREQ) .EQ. 0) GO TO 600 IF (IV(FDH) .NE. 0) GO TO 600 IF (IV(CNVCOD) .GE. 7) GO TO 600 IF (IV(REGD) .GT. 0) GO TO 600 IF (IV(COVMAT) .GT. 0) GO TO 600 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 530 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 520 IV(RESTOR) = 0 530 CALL DF7HES(D, G, I, IV, LIV, LV, P, V, X) GO TO (540, 550, 580), I 540 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C 550 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) IV(1) = 2 GO TO 999 C 560 H1 = IABS(IV(H)) IV(H) = -H1 PP1O2 = P * (P + 1) / 2 RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 570 LMAT1 = IV(LMAT) CALL DV7CPY(PP1O2, V(LMAT1), V(RMAT1)) V(RCOND) = ZERO GO TO 590 570 HC1 = IV(HC) IV(FDH) = H1 CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1)) C C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN C *** FOR USE IN CALLER*S COVARIANCE CALCULATION... C 580 LMAT1 = IV(LMAT) H1 = IV(FDH) IF (H1 .LE. 0) GO TO 600 IF (IV(CNVCOD) .EQ. 70) GO TO 80 CALL DL7SRT(1, P, V(LMAT1), V(H1), I) IV(FDH) = -1 V(RCOND) = ZERO IF (I .NE. 0) GO TO 600 C 590 IV(FDH) = -1 STEP1 = IV(STEP) T = DL7SVN(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .LE. ZERO) GO TO 600 T = T / DL7SVX(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .GT. DR7MDC(4)) IV(FDH) = H1 V(RCOND) = T C 600 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 610 IV(1) = 1400 C 999 RETURN C C *** LAST LINE OF DG7LIT FOLLOWS *** END SUBROUTINE DL7NVR(N, LIN, L) C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C *** PARAMETERS *** C INTEGER N DOUBLE PRECISION L(1), LIN(1) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 DOUBLE PRECISION ONE, T, ZERO 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 LINE OF DL7NVR FOLLOWS *** END SUBROUTINE DL7TSQ(N, A, L) C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C INTEGER N DOUBLE PRECISION A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C INTEGER I, II, IIM1, I1, J, K, M DOUBLE PRECISION LII, LJ C II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C 999 RETURN C *** LAST LINE OF DL7TSQ FOLLOWS *** END SUBROUTINE DN3RDP(IV, LIV, LV, N, P, RD, RHOI, RHOR, V) C C *** PRINT REGRESSION DIAGNOSTICS FOR MLPSL AND NL2S1 *** C INTEGER LIV, LV, N, P INTEGER IV(LIV), RHOI(*) DOUBLE PRECISION RD(N), RHOR(*), V(LV) C C *** NOTE -- V IS PASSED FOR POSSIBLE USE BY REVISED VERSIONS OF C *** THIS ROUTINE. C INTEGER COV1, I, I1, I2, IEND, II, J, K, K1, NI, PU, PX, PX1, XNI C C *** IV AND V SUBSCRIPTS *** C INTEGER BS, BSSTR, COVMAT, COVPRT, COVREQ, LOO, NB, NEEDHD, NFCOV, 1 NFIX, NGCOV, PRUNIT, RDREQ, REGD, RCOND, STATPR, XNOTI C PARAMETER (BS=85, BSSTR=86, COVMAT=26, COVPRT=14, COVREQ=15, 1 LOO=84, NB=87, NEEDHD=36, NFCOV=52, NFIX=83, NGCOV=53, 2 PRUNIT=21, RDREQ=57, REGD=67, RCOND=53, STATPR=23, 3 XNOTI=90) C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (IV(STATPR) .EQ. 0) GO TO 30 IF (IV(NFCOV) .GT. 0) WRITE(PU,10) IV(NFCOV) 10 FORMAT(/1X,I4,50H EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOST 1ICS.) IF (IV(NGCOV) .GT. 0) WRITE(PU,20) IV(NGCOV) 20 FORMAT(1X,I4,50H EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTI 1CS.) IF (IV(NFCOV) .GT. 0 .OR. IV(NGCOV) .GT. 0) IV(NEEDHD) = 1 C 30 IF (IV(COVPRT) .LE. 0) GO TO 999 COV1 = IV(COVMAT) IF (IV(REGD) .LE. 0 .AND. COV1 .LE. 0) GO TO 70 IV(NEEDHD) = 1 IF (IABS(IV(COVREQ)) .GT. 2) GO TO 50 C WRITE(PU,40) V(RCOND) 40 FORMAT(/53H SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST, 1 G10.2) GO TO 70 C 50 WRITE(PU,60) V(RCOND) 60 FORMAT(/54H SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST, 1 G10.2) C 70 IF (MOD(IV(COVPRT),2) .EQ. 0) GO TO 210 IV(NEEDHD) = 1 IF (COV1) 80,110,130 80 IF (-1 .EQ. COV1) WRITE(PU,90) 90 FORMAT(/43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,100) 100 FORMAT(/52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 110 WRITE(PU,120 ) 120 FORMAT(/45H ++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 210 C 130 IF (IABS(IV(COVREQ)) .LT. 3) GO TO 150 WRITE(PU,140) 140 FORMAT(/35H COVARIANCE = (J**T * RHO" * J)**-1/) GO TO 170 150 WRITE(PU,160) 160 FORMAT(/56H COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIA 1N/) 170 II = COV1 - 1 DO 180 I = 1, P I1 = II + 1 I2 = II + MIN(I, 5) II = II + I WRITE(PU,190) I, (V(J), J = I1, I2) IF (I .LE. 5) GO TO 180 I2 = I2 + 1 WRITE(PU,200) (V(J), J = I2, II) 180 CONTINUE 190 FORMAT(4H ROW,I3,2X,5G12.3) 200 FORMAT(9X,5G12.3) 210 IF (IV(COVPRT) .LT. 2) GO TO 999 I = IV(REGD) + 4 GO TO (230, 250, 270, 290, 310), I WRITE(PU,220) IV(REGD) 220 FORMAT(/18H BUG... IV(REGD) =,I10) GO TO 999 230 WRITE(PU,240) NB, IV(NB) 240 FORMAT(/17H BAD IV(NB) = IV(,I2,3H) =,I10) GO TO 999 250 WRITE(PU,260) NFIX, IV(NFIX) 260 FORMAT(/19H BAD IV(NFIX) = IV(,I2,3H) =,I10) GO TO 999 270 WRITE(PU,280) LOO, IV(LOO) 280 FORMAT(/18H BAD IV(LOO) = IV(,I2,3H) =,I10) GO TO 999 290 WRITE(PU,300) 300 FORMAT(/42H REGRESSION DIAGNOSTIC VECTOR NOT COMPUTED) GO TO 999 310 IV(NEEDHD) = 1 XNI = 0 I = MOD(IV(RDREQ)/2, 3) + 1 GO TO (999, 330, 320), I 320 XNI = IV(XNOTI) PX = P - IV(NFIX) PX1 = PX - 1 IF (IV(LOO) .GT. 1) GO TO 400 330 WRITE(PU,340) 340 FORMAT (74H REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * 1 H(I)**-1 * G(I)...) IF (XNI .LE. 0) GO TO 380 WRITE(PU, 350) 350 FORMAT(29H I RD(I) X(I)) DO 360 I = 1, N WRITE(PU, 370) I, RD(I), (RHOR(J), J = XNI, XNI+PX1) XNI = XNI + PX 360 CONTINUE 370 FORMAT(1X,I5,G13.3,4G15.6/(19X,4G15.6)) GO TO 999 C 380 WRITE(PU,390) RD 390 FORMAT(6G12.3) GO TO 999 C 400 WRITE(PU,410) 410 FORMAT(/77H BLOCK REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 1 * H * H(I)**-1 * G(I)) NI = IV(NB) K = IV(BS) K1 = IV(BSSTR) IEND = 0 IF (XNI .GT. 0) GO TO 450 WRITE(PU,420) 420 FORMAT(28H BLOCK FIRST LAST RD(I)) DO 440 I = 1, NI I1 = IEND + 1 IF (I1 .GT. N) GO TO 999 IEND = IEND + RHOI(K) K = K + K1 IF (IEND .GT. N) IEND = N WRITE(PU,430) I, I1, IEND, RD(I) 430 FORMAT(I6,I7,I6,G12.3) 440 CONTINUE GO TO 999 C 450 WRITE(PU, 460) 460 FORMAT(41H BLOCK FIRST LAST RD(I) X(I)) DO 480 I = 1, NI I1 = IEND + 1 IF (I1 .GT. N) GO TO 999 IEND = IEND + RHOI(K) K = K + K1 IF (IEND .GT. N) IEND = N WRITE(PU,470) I, I1, IEND, RD(I), (RHOR(J), J = XNI, XNI+PX1) 470 FORMAT(I6,I7,I6,G12.3,3G15.6/(31X,3G15.6)) XNI = XNI + PX 480 CONTINUE C 999 RETURN C *** LAST LINE OF DN3RDP FOLLOWS *** END //GO.SYSIN DD dglfg.f cat >dglfgb.f <<'//GO.SYSIN DD dglfgb.f' SUBROUTINE DGLGB(N, P, PS, X, B, RHO, RHOI, RHOR, IV, LIV, LV, 1 V, CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION A LA NL2SOL, PLUS SIMPLE BOUNDS *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) DOUBLE PRECISION B(2,P), X(P), RHOR(*), V(LV), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C B....... BOUNDS TO ENFORCE... B(1,I) .LE. X(I) .LE. B(2,I). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE DRGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR AND JACOBIAN MATRIX. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED IS AN INTEGER ARRAY OF LENGTH 2... C NEED(1) = 1 MEANS CALCRJ SHOULD COMPUTE THE RESIDUAL VECTOR R, C AND NEED(2) IS THE VALUE NF HAD AT THE LAST X WHERE C CALCRJ MIGHT BE CALLED WITH NEED(1) = 2. C NEED(1) = 2 MEANS CALCRJ SHOULD COMPUTE THE JACOBIAN MATRIX RP, C WHERE RP(J,I) = DERIVATIVE OF R(I) WITH RESPECT TO X(J). C (CALCRJ SHOULD NOT CHANGE NEED AND SHOULD CHANGE AT MOST ONE OF R C AND RP. IF R OR RP, AS APPROPRIATE, CANNOT BE COMPUTED, THEN CALCRJ C SHOULD SET NF TO 0. OTHERWISE IT SHOULD NOT CHANGE NF.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRGLGB C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRGLGB... CARRIES OUT OPTIMIZATION ITERATIONS. C C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, I, IV1, NEED1(2), NEED2(2), NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+1+I) CALL DRGLGB(B, X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, 1 RHO, RHOI,RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 1)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL DRGLGB(B, V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, 1 V(R1), V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 60 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL CALCRJ(N, PS, X, NF, NEED1, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCRJ(N, PS, X, IV(NFGCAL), NEED2, V(R1), V(DR1), UI, UR,UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED C *** AND PRINT IT IF SO REQUESTED... C 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 C 999 RETURN C C *** LAST LINE OF DGLGB FOLLOWS *** END SUBROUTINE DGLFB(N, P, PS, X, B, RHO, RHOI, RHOR, IV, LIV, LV, V, 1 CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION, FINITE-DIFFERENCE JACOBIAN *** C *** WITH SIMPLE BOUNDS ON X *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) DOUBLE PRECISION B(2,P), X(P), V(LV), RHOR(*), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C B....... BOUNDS TO ENFORCE... B(1,I) .LE. X(I) .LE. B(2,I). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE DRGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED MAY BE REGARDED AS AN INTEGER THAT ALWAYS HAS THE VALUE 1 C WHEN DGLFB CALLS CALCRJ. THIS MEANS CALCRJ SHOULD COMPUTE THE C RESIDUAL VECTOR R. (CALCRJ SHOULD NOT CHANGE NEED OR RP. IF R C CANNOT BE COMPUTED, THEN CALCRJ SHOULD SET NF TO 0. OTHERWISE IT C SHOULD NOT CHANGE NF. FOR COMPATIBILITY WITH DGLG, NEED IS A C VECTOR OF LENGTH 2.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL DIVSET, DRGLGB,DV7CPY C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DRGLGB... CARRIES OUT OPTIMIZATION ITERATIONS. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, I1, IV1, J1K, J1K0, K, NEED(2), NF, 1 NG, RD1, R1, R21, RS1, RSN DOUBLE PRECISION H, H0, HLIM, NEGPT5, T, ONE, XK, XK1, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, REGD0, TOOBIG, VNEED PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED DATA HLIM/0.1D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ DATA NEED(1)/1/, NEED(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+3+I) CALL DRGLGB(B, X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, RHO, 1 RHOI, RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 3)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) R21 = RD1 - N RS1 = R21 - N RSN = RS1 + N - 1 C 20 CALL DRGLGB(B, V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, 1 V(R1), V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCRJ(N, PS, X, NF, NEED, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 CALL DV7CPY(N, V(RS1), V(R1)) IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL DV7SCP(P, V(D1), ONE) C DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 J1K0 = DR1 NF = IV(NFCALL) IF (NF .EQ. IV(NFGCAL)) GO TO 70 NG = NG + 1 CALL CALCRJ(N, PS, X, NF, NEED, V(RS1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 70 60 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 70 DO 130 K = 1, PS J1K = J1K0 J1K0 = J1K0 + 1 IF (B(1,K) .GE. B(2,K)) GO TO 120 XK = X(K) H = V(DLTFDJ) * MAX( ABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 T = NEGPT5 XK1 = XK + H IF (XK - H .GE. B(1,K)) GO TO 80 T = -T IF (XK1 .GT. B(2,K)) GO TO 60 80 IF (XK1 .LE. B(2,K)) GO TO 90 T = -T H = -H XK1 = XK + H IF (XK1 .LT. B(1,K)) GO TO 60 90 X(K) = XK1 NF = IV(NFGCAL) CALL CALCRJ(N, PS, X, NF, NEED, V(R21), V(DR1), UI, UR, UF) NG = NG + 1 IF (NF .GT. 0) GO TO 100 H = T * H XK1 = XK + H IF ( ABS(H/H0) .GE. HLIM) GO TO 90 GO TO 60 100 X(K) = XK IV(NGCALL) = NG I1 = R21 DO 110 I = RS1, RSN V(J1K) = (V(I1) - V(I)) / H I1 = I1 + 1 J1K = J1K + PS 110 CONTINUE GO TO 130 C *** SUPPLY A ZERO DERIVATIVE FOR CONSTANT COMPONENTS... 120 DO 125 I = 1, N V(J1K) = ZERO J1K = J1K + PS 125 CONTINUE 130 CONTINUE GO TO 20 C 999 RETURN C C *** LAST LINE OF DGLFB FOLLOWS *** END SUBROUTINE DRGLGB(B, D, DR, IV, LIV, LV, N, ND, NN, P, PS, R, 1 RD, RHO, RHOI, RHOR, V, X) C C *** ITERATION DRIVER FOR GENERALIZED (NON)LINEAR MODELS (ETC.) C INTEGER LIV, LV, N, ND, NN, P, PS INTEGER IV(LIV), RHOI(*) DOUBLE PRECISION B(2,P), D(P), DR(ND,N), R(*), RD(*), RHOR(*), 1 V(LV), X(*) C DIMENSION RD(N, (P-PS)*(P-PS+1)/2 + 1) EXTERNAL RHO 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 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....... LEADING DIMENSION OF DR -- MUST BE AT LEAST PS. C NN....... LEAD DIMENSION OF R, RD. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS....... NUMBER OF NON-NUISANCE PARAMETERS. C R........ RESIDUALS (OR MEANS -- FUNCTIONS OF X) WHEN DRGLGB IS CALLED C WITH IV(1) = 1. C RD....... TEMPORARY STORAGE. C RHO...... COMPUTES INFO ABOUT OBJECTIVE FUNCTION. C RHOI..... PASSED WITHOUT CHANGE TO RHO. C RHOR..... PASSED WITHOUT CHANGE TO RHO. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** CALLING SEQUENCE FOR RHO... C C CALL RHO(NEED, F, N, NF, XN, R, RD, RHOI, RHOR, W) C C PARAMETER DECLARATIONS FOR RHO... C C INTEGER NEED(2), N, NF, RHOI(*) C FLOATING-POINT F, XN(*), R(*), RD(N,*), RHOR(*), W(N) C C RHOI AND RHOR ARE FOR RHO TO USE AS IT SEES FIT. THEY ARE PASSED C TO RHO WITHOUT CHANGE. C F, R, RD, AND W ARE EXPLAINED BELOW WITH NEED. C XN IS THE VECTOR OF NUISANCE PARAMETERS (OF LENGTH P - PS). IF C RHO NEEDS TO KNOW THE LENGTH OF XN, THEN THIS LENGTH SHOULD BE C COMMUNICATED THROUGH RHOI (OR THROUGH COMMON). RHO SHOULD NOT CHANGE C XN. C NEED(1) = 1 MEANS RHO SHOULD SET F TO THE SUM OF THE LOSS FUNCTION C VALUES AT THE RESIDUALS R(I). NF IS THE CURRENT FUNCTION INVOCATION C COUNT (A VALUE THAT IS INCREMENTED EACH TIME A NEW PARAMETER EXTIMATE C X IS CONSIDERED). NEED(2) IS THE VALUE NF HAD AT THE LAST R WHERE C RHO MIGHT BE CALLED WITH NEED(1) = 2. IF RHO SAVES INTERMEDIATE C RESULTS FOR USE IN CALLS WITH NEED(1) = 2, THEN IT CAN USE NF TO TELL C WHICH INTERMEDIATE RESULTS ARE APPROPRIATE, AND IT CAN SAVE SOME OF C THESE RESULTS IN R. C NEED(1) = 2 MEANS RHO SHOULD SET R(I) TO THE LOSS FUNCTION C DERIVATIVE WITH RESPECT TO THE RESIDUALS THAT WERE PASSED TO RHO WHEN C NF HAD THE SAME VALUE IT DOES NOW (AND NEED(1) WAS 1). RHO SHOULD C ALSO SET W(I) TO THE APPROXIMATION OF THE SECOND DERIVATIVE OF THE C LOSS FUNCTION (WITH RESPECT TO THE I-TH RESIDUAL) THAT SHOULD BE USED C IN THE GAUSS-NEWTON MODEL. WHEN THERE ARE NUISANCE PARAMETERS (I.E., C WHEN PS .LT. P) RHO SHOULD ALSO SET R(I+K*N) TO THE DERIVATIVE OF THE C LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL AND XN(K), AND IT C SHOULD SET RD(I,J + K*(K+1)/2 + 1) TO THE SECOND PARTIAL DERIVATIVE C OF THE I-TH RESIDUAL WITH RESPECT TO XN(J) AND XN(K), 0 .LE. J .LE. K C AND 1 .LE. K .LE. P - PS, WHERE XN(0) MEANS THE I-TH RESIDUAL ITSELF. C IN ANY EVENT, RHO SHOULD ALSO SET RD(I,1) TO THE (TRUE) SECOND C DERIVATIVE OF THE LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL. C NF (THE FUNCTION INVOCATION COUNT WHOSE NORMAL USE IS EXPLAINED C ABOVE) SHOULD NOT BE CHANGED UNLESS RHO CANNOT CARRY OUT THE REQUESTED C TASK, IN WHICH CASE RHO SHOULD SET NF TO 0. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DIVSET, DD7TPR, DD7UP5, DG7ITB,DITSUM, DL7ITV, DL7IVM, 1 DL7SRT, DL7SQR, DL7SVX, DL7SVN,DL7VML,DO7PRD, 2 DQ7ADR,DV2AXY,DV7CPY, DV7SCL, DV7SCP, DVSUM DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DVSUM C C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C DD7UP5... UPDATES SCALE VECTOR D. C DG7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM. C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C DL7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C DL7IVM... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C DL7SQR... COMPUTES L*(L**T) FOR LOWER TRIANG. MATRIX L. C DL7SVX... UNDERESTIMATES LARGEST SINGULAR VALUE OF TRIANG. MATRIX. C DL7SVN... OVERESTIMATES SMALLEST SINGULAR VALUE OF TRIANG. MATRIX. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DO7PRD.... ADDS OUTER PRODUCT OF VECTORS TO A MATRIX. C DQ7ADR... ADDS ROWS TO QR FACTORIZATION. C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV7SCL... MULTIPLIES A VECTOR BY A SCALAR. C DVSUM.... RETURNS SUM OF ELEMENTS OF A VECTOR. C C *** LOCAL VARIABLES *** C LOGICAL UPDATD, ZEROG INTEGER G1, HN1, I, II, IV1, J, J1, JTOL1, K, LH, 1 NEED1(2), NEED2(2), PMPS, PS1, PSLEN, QTR1, 2 RMAT1, STEP1, TEMP1, TEMP2, TEMP3, TEMP4, W, WI, Y1 DOUBLE PRECISION RHMAX, RHTOL, RHO1, RHO2, T C DOUBLE PRECISION ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, 1 F0, G, HC, IPIVOT, IVNEED, JCN, JTOL, LMAT, 2 MODE, NEXTIV, NEXTV, NF0, NF1, NFCALL, NFGCAL, 3 QTR, RDREQ, REGD, RESTOR, RMAT, 4 RSPTOL, STEP, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C PARAMETER (DTYPE=16, F0=13, G=28, HC=71, IPIVOT=76, IVNEED=3, 1 JCN=66, JTOL=59, LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, 2 NFCALL=6, NF0=68, NF1=69, NFGCAL=7, QTR=77, RESTOR=9, 3 RMAT=78, RDREQ=57, REGD=67, STEP=40, TOOBIG=2, VNEED=4) C C *** V SUBSCRIPT VALUES *** C PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RSPTOL=49) PARAMETER (ONE=1.D+0, ZERO=0.D+0) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) PS1 = PS + 1 IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 W = IV(G) - N IV(RESTOR) = 0 IF (IV(TOOBIG) .EQ. 0) GO TO (110, 120), IV1 V(F) = V(F0) IF (IV1 .NE. 1) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LT. PS) GO TO 340 IF (PS .GT. P) GO TO 340 IF (PS .LE. 0) GO TO 340 IF (N .LE. 0) GO TO 340 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 360 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 + 2*N + 4*PS 20 CALL DG7ITB(B, D, X, IV, LIV, LV, P, PS, 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(G) = IV(NEXTV) + P + N IV(RMAT) = IV(G) + P + 4*PS IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + P + N IV(JCN) = IV(JTOL) + 2*P IV(NEXTV) = IV(JCN) + 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 C 40 G1 = IV(G) Y1 = G1 - (P + N) CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, PS, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 350 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 999 IF (IV(RESTOR) .NE. 2) GO TO 999 IV(NF0) = IV(NF1) CALL DV7CPY(N, RD, R) IV(REGD) = 0 GO TO 999 C 60 CALL DV7SCP(P, V(G1), ZERO) RMAT1 = IABS(IV(RMAT)) QTR1 = IABS(IV(QTR)) CALL DV7SCP(PS, V(QTR1), ZERO) IV(REGD) = 0 CALL DV7SCP(PS, V(Y1), ZERO) CALL DV7SCP(LH, V(RMAT1), ZERO) IF (IV(RESTOR) .NE. 3) GO TO 70 CALL DV7CPY(N, R, RD) IV(NF1) = IV(NF0) 70 CALL RHO(NEED2, T, N, IV(NFGCAL), X(PS1), R, RD, RHOI, RHOR, V(W)) IF (IV(NFGCAL) .GT. 0) GO TO 90 80 IV(TOOBIG) = 1 GO TO 40 90 IF (IV(MODE) .LT. 0) GO TO 999 DO 100 I = 1, N 100 CALL DV2AXY(PS, V(Y1), R(I), DR(1,I), V(Y1)) GO TO 999 C C *** COMPUTE F(X) *** C 110 I = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL RHO(NEED1, V(F), N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IV(NF1) = I IF (I .LE. 0) GO TO 80 GO TO 40 C 120 G1 = IV(G) C C *** DECIDE WHETHER TO UPDATE D BELOW *** C I = IV(DTYPE) UPDATD = .FALSE. IF (I .LE. 0) GO TO 130 IF (I .EQ. 1 .OR. IV(MODE) .LT. 0) UPDATD = .TRUE. C C *** COMPUTE RMAT AND QTR *** C 130 QTR1 = IABS(IV(QTR)) RMAT1 = IABS(IV(RMAT)) IV(RMAT) = RMAT1 IV(HC) = 0 IV(NF0) = 0 IV(NF1) = 0 IF (IV(MODE) .LT. 0) GO TO 150 C C *** ADJUST Y *** C Y1 = IV(G) - (P + N) WI = W STEP1 = IV(STEP) DO 140 I = 1, N T = V(WI) - RD(I) WI = WI + 1 IF (T .NE. ZERO) CALL DV2AXY(PS, V(Y1), 1 T*DD7TPR(PS,V(STEP1),DR(1,I)), DR(1,I), V(Y1)) 140 CONTINUE C C *** CHECK FOR NEGATIVE W COMPONENTS *** C 150 J1 = W + N - 1 DO 160 WI = W, J1 IF (V(WI) .LT. ZERO) GO TO 230 160 CONTINUE C C *** W IS NONNEGATIVE. COMPUTE QR FACTORIZATION *** C *** AND, IF NECESSARY, USE SEMINORMAL EQUATIONS *** C RHMAX = ZERO RHTOL = V(RSPTOL) TEMP1 = G1 + P ZEROG = .TRUE. WI = W DO 190 I = 1, N RHO1 = R(I) RHO2 = V(WI) WI = WI + 1 T = SQRT(RHO2) IF (RHMAX .LT. RHO2) RHMAX = RHO2 IF (RHO2 .GT. RHTOL*RHMAX) GO TO 170 C *** SEMINORMAL EQUATIONS *** CALL DV2AXY(PS, V(G1), RHO1, DR(1,I), V(G1)) RHO1 = ZERO ZEROG = .FALSE. GO TO 180 170 RHO1 = RHO1 / T C *** QR ACCUMULATION *** 180 CALL DV7SCL(PS, V(TEMP1), T, DR(1,I)) CALL DQ7ADR(PS, V(QTR1), V(RMAT1), V(TEMP1), RHO1) 190 CONTINUE C C *** COMPUTE G FROM RMAT AND QTR *** C TEMP2 = TEMP1 + P CALL DL7VML(PS, V(TEMP1), V(RMAT1), V(QTR1)) IF (ZEROG) GO TO 210 IV(QTR) = -QTR1 IF (DL7SVX(PS, V(RMAT1), V(TEMP2), V(TEMP2)) * RHTOL .GE. 1 DL7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2))) GO TO 220 CALL DL7IVM(PS, V(TEMP2), V(RMAT1), V(G1)) C C *** SEMINORMAL EQUATIONS CORRECTION OF BJOERCK -- C *** ONE CYCLE OF ITERATIVE REFINEMENT... C TEMP3 = TEMP2 + PS TEMP4 = TEMP3 + PS CALL DL7ITV(PS, V(TEMP3), V(RMAT1), V(TEMP2)) CALL DV7SCP(PS, V(TEMP4), ZERO) RHMAX = ZERO WI = W DO 200 I = 1, N RHO2 = V(WI) WI = WI + 1 IF (RHMAX .LT. RHO2) RHMAX = RHO2 RHO1 = ZERO IF (RHO2 .LE. RHTOL*RHMAX) RHO1 = R(I) T = RHO1 - RHO2*DD7TPR(PS, V(TEMP3), DR(1,I)) CALL DV2AXY(PS, V(TEMP4), T, DR(1,I), V(TEMP4)) 200 CONTINUE CALL DL7IVM(PS, V(TEMP3), V(RMAT1), V(TEMP4)) CALL DV2AXY(PS, V(TEMP2), ONE, V(TEMP3), V(TEMP2)) CALL DV2AXY(PS, V(QTR1), ONE, V(TEMP2), V(QTR1)) 210 IV(QTR) = QTR1 220 CALL DV2AXY(PS, V(G1), ONE, V(TEMP1), V(G1)) IF (PS .GE. P) GO TO 330 GO TO 250 C C *** INDEFINITE GN HESSIAN... *** C 230 IV(RMAT) = -RMAT1 IV(HC) = RMAT1 CALL DO7PRD(N, LH, PS, V(RMAT1), V(W), DR, DR) C C *** COMPUTE GRADIENT *** C G1 = IV(G) DO 240 I = 1, N 240 CALL DV2AXY(PS, V(G1), R(I), DR(1,I), V(G1)) IF (PS .GE. P) GO TO 330 C C *** COMPUTE GRADIENT COMPONENTS OF NUISANCE PARAMETERS *** C 250 K = P - PS J1 = 1 G1 = G1 + PS DO 260 J = 1, K J1 = J1 + NN V(G1) = DVSUM(N, R(J1)) G1 = G1 + 1 260 CONTINUE C C *** COMPUTE HESSIAN COMPONENTS OF NUISANCE PARAMETERS *** C I = PS*PS1/2 PSLEN = P*(P+1)/2 - I HN1 = RMAT1 + I CALL DV7SCP(PSLEN, V(HN1), ZERO) PMPS = P - PS K = HN1 J1 = 1 DO 290 II = 1, PMPS J1 = J1 + NN J = J1 DO 270 I = 1, N CALL DV2AXY(PS, V(K), RD(J), DR(1,I), V(K)) J = J + 1 270 CONTINUE K = K + PS DO 280 I = 1, II J1 = J1 + NN V(K) = DVSUM(N, RD(J1)) K = K + 1 280 CONTINUE 290 CONTINUE IF (IV(RMAT) .LE. 0) GO TO 330 J = IV(LMAT) CALL DV7CPY(PSLEN, V(J), V(HN1)) IF (DL7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2)) .LE. ZERO) GO TO 300 CALL DL7SRT(PS1, P, V(RMAT1), V(RMAT1), I) IF (I .LE. 0) GO TO 310 C C *** HESSIAN IS NOT POSITIVE DEFINITE *** C 300 CALL DL7SQR(PS, V(RMAT1), V(RMAT1)) CALL DV7CPY(PSLEN, V(HN1), V(J)) IV(HC) = RMAT1 IV(RMAT) = -RMAT1 GO TO 330 C C *** NUISANCE PARS LEAVE HESSIAN POS. DEF. GET REST OF QTR *** C 310 J = QTR1 + PS G1 = IV(G) + PS DO 320 I = PS1, P T = DD7TPR(I-1, V(HN1), V(QTR1)) HN1 = HN1 + I V(J) = (V(G1) - T) / V(HN1-1) J = J + 1 G1 = G1 + 1 320 CONTINUE 330 IF (UPDATD) CALL DD7UP5(D, IV, LIV, LV, P, PS, V) GO TO 40 C C *** MISC. DETAILS *** C C *** BAD N, ND, OR P *** C 340 IV(1) = 66 GO TO 360 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 350 G1 = IV(G) 360 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X) C 999 RETURN C *** LAST LINE OF DRGLGB 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 LINE OF DD7MLP 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) * MAX(ONE/D(M), ABS(X(M))) DEL = HALF * DEL IF ( ABS(DEL/DEL0) .LE. HLIM) GO TO 140 C 30 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DEL = ONE / DEL DO 40 I = 1, P G(I) = DEL * (G(I) - V(GSAVE1)) GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 50 I = 1, MM1 IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I)) K = K + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P IF (B(1,I) .LT. B(2,I)) V(L) = G(I) L = L + I 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 340 IF (B(1,M) .GE. B(2,M)) GO TO 80 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * MAX(ONE/D(M), ABS(X(M))) XM = X(M) IF (XM .LT. ZERO) GO TO 90 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 GO TO 280 90 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 GO TO 280 C 100 DEL = -DEL 110 V(XMSAVE) = XM X(M) = XM1 V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 120 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 HES = -IV(H) IF (M .GT. 0) GO TO 130 C *** FIRST CALL ON 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) * MAX(ONE/D(M), ABS(XM)) XM1 = XM + DEL OFFSID = .FALSE. IF (XM1 .LE. B(2,M)) GO TO 270 OFFSID = .TRUE. XM1 = XM - DEL IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300 GO TO 280 270 IF (XM-DEL .GE. B(1,M)) GO TO 290 OFFSID = .TRUE. IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310 C 280 IV(FDH) = -2 GO TO 350 C 290 IF (XM .GE. ZERO) GO TO 310 XM1 = XM - DEL 300 DEL = -DEL 310 GO TO (160, 220, 320), NEWM1 320 X(M) = XM1 STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES C *** FROM LAST ROW OF FDH... C 330 IF (B(1,P) .LT. B(2,P)) GO TO 340 I = HES + P*(P-1)/2 CALL DV7SCP(P, V(I), ZERO) C C *** RESTORE V(F), ETC. *** C 340 IV(FDH) = HES 350 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL DV7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST LINE OF DF7DHB FOLLOWS *** END SUBROUTINE DG7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X. C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 80. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C DG7ITB IS SIMILAR TO DG7LIT, EXCEPT FOR THE EXTRA PARAMETER B C -- DG7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C DG7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS), AND DG7ITB BUILDS AN APPROXIMATION, S, TO THE C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE, C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S. C DG7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO USE S WHEN CHOOSING C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL). C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S, DG7ITB ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7ITB WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO DN2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT DN2GB USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH DN2GB (AND NL2SOL), IV(1) C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE C EXPLAINED BELOW, AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM C DN2GB (AND DN2FB), ARE NOT REFERENCED BY DG7ITB OR THE C SUBROUTINES IT CALLS. C C WHEN DG7ITB IS FIRST CALLED, I.E., WHEN DG7ITB IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES, DG7ITB RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7ITB WILL MAKE C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL DG7ITB AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE DG7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME DG7ITB RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL DG7ITB AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(NFGCAL) TO 0, IN WHICH CASE DG7ITB WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL HAVQTR, HAVRM INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1, 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2, 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2, 3 TG1, W1, WLM1, X01 DOUBLE PRECISION E, GI, STTSST, T, T1, XI C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM EXTERNAL DA7SST, DD7TPR, DF7DHB, DG7QSB,I7COPY, I7PNVR, I7SHFT, 1 DITSUM, DL7MSB, DL7SQR, DL7TVM,DL7VML,DPARCK, DQ7RSH, 2 DRLDST, DS7DMP, DS7IPR, DS7LUP, DS7LVM, STOPX, DV2NRM, 3 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP C C DA7SST.... ASSESSES CANDIDATE STEP. C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C DF7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX). C DG7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER. C I7PNVR... INVERTS PERMUTATION ARRAY. C I7SHFT... SHIFTS AN INTEGER VECTOR. C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C DL7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C DQ7RSH... SHIFTS A QR FACTORIZATION. C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C DS7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX. C DS7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX. C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C DS7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C DV2NRM... RETURNS THE 2-NORM OF A VECTOR. C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C DV7CPY.... COPIES ONE VECTOR TO ANOTHER. C DV7IPR... APPLIES A PERMUTATION TO A VECTOR. C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C DV7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT, 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV, 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0, 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS, 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP, 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5, 8 VNEED, VSAVE, W, WSCALE, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.) C 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 GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I C C *** STORAGE ALLOCATION *** C 20 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + 2*P IV(DIG) = IV(STEP) + 3*P IV(W) = IV(DIG) + 2*P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IV(IPIVOT) = IV(PERM) + 3*P IV(NEXTIV) = IV(IPIVOT) + P IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(PC) = P V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(IPIVOT) DO 40 I = 1, P IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 680 40 CONTINUE C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IV(1) = 1 IF (IV(S) .LT. 0) GO TO 710 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO) GO TO 710 C C *** NEW FUNCTION VALUE *** C 50 IF (IV(MODE) .EQ. 0) GO TO 360 IF (IV(MODE) .GT. 0) GO TO 590 C IF (IV(TOOBIG) .EQ. 0) GO TO 690 IV(1) = 63 GO TO 999 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 999 C C *** NEW GRADIENT *** C 70 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 590 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670 C C *** CHOOSE INITIAL PERMUTATION *** C IPI = IV(IPIVOT) IPN = IPI + P - 1 IPIV2 = IV(PERM) - 1 K = IV(PC) P1 = P PP1 = P + 1 RMAT1 = IV(RMAT) HAVRM = RMAT1 .GT. 0 QTR1 = IV(QTR) HAVQTR = QTR1 .GT. 0 C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) *** W1 = IV(W) IF (.NOT. HAVQTR) QTR1 = W1 + P C DO 100 I = 1, P I1 = IV(IPN) IPN = IPN - 1 IF (B(1,I1) .GE. B(2,I1)) GO TO 80 XI = X(I1) GI = G(I1) IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80 IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80 C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED *** J = IPIV2 + I1 IF (IV(J) .GT. K) IV(CNVCOD) = 0 GO TO 100 80 IF (I1 .GE. P1) GO TO 90 I1 = PP1 - I CALL I7SHFT(P1, I1, IV(IPI)) IF (HAVRM) 1 CALL DQ7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1)) 90 P1 = P1 - 1 100 CONTINUE IV(PC) = P1 C C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) *** C V(DGNORM) = ZERO IF (P1 .LE. 0) GO TO 110 DIG1 = IV(DIG) CALL DV7VMP(P, V(DIG1), G, D, -1) CALL DV7IPR(P, IV(IPI), V(DIG1)) V(DGNORM) = DV2NRM(P1, V(DIG1)) 110 IF (IV(CNVCOD) .NE. 0) GO TO 580 IF (IV(MODE) .EQ. 0) GO TO 510 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 170 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 600 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 120 H1 = IV(FDH) IF (H1 .LE. 0) GO TO 660 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 130 CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 140 130 RMAT1 = IV(RMAT) LMAT1 = IV(LMAT) CALL DL7SQR(P, V(LMAT1), V(RMAT1)) IPI = IV(IPIVOT) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPI)) CALL DS7IPR(P, IV(IPIV1), V(LMAT1)) CALL DV2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1)) C C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS *** C 140 DO 160 I = 1, P IF (B(1,I) .LT. B(2,I)) GO TO 160 K = S1 + I*(I-1)/2 CALL DV7SCP(I, V(K), ZERO) IF (I .GE. P) GO TO 170 K = K + 2*I - 1 I1 = I + 1 DO 150 J = I1, P V(K) = ZERO K = K + J 150 CONTINUE 160 CONTINUE C 170 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 180 CALL DITSUM(D, G, IV, LIV, LV, P, V, X) 190 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 200 IV(1) = 10 GO TO 999 200 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 220 STEP1 = IV(STEP) DO 210 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 210 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * DV2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 220 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL DV7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 230 IF (.NOT. STOPX(DUMMY)) GO TO 250 IV(1) = 11 GO TO 260 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 240 IF (V(F) .GE. V(F0)) GO TO 250 V(RADFAC) = ONE K = IV(NITER) GO TO 200 C 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270 IV(1) = 9 260 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 500 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 270 STEP1 = IV(STEP) TG1 = IV(DIG) TD1 = TG1 + P X01 = IV(X0) W1 = IV(W) H1 = IV(H) P1 = IV(PC) IPI = IV(PERM) IPIV1 = IPI + P IPIV2 = IPIV1 + P IPIV0 = IV(IPIVOT) IF (IV(MODEL) .EQ. 2) GO TO 280 C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 280 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 280 LMAT1 = IV(LMAT) WLM1 = W1 + P CALL DL7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1), 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0), 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1), 3 V(TG1), V, V(W1), V(WLM1), X, V(X01)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 330 C 280 IF (H1 .GT. 0) GO TO 320 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C P1LEN = P1*(P1+1)/2 H1 = -H1 IV(H) = H1 IV(FDH) = 0 IF (P1 .LE. 0) GO TO 320 C *** MAKE TEMPORARY PERMUTATION ARRAY *** CALL I7COPY(P, IV(IPI), IV(IPIV0)) J = IV(HC) IF (J .GT. 0) GO TO 290 J = H1 RMAT1 = IV(RMAT) CALL DL7SQR(P1, V(H1), V(RMAT1)) GO TO 300 290 CALL DV7CPY(P*(P+1)/2, V(H1), V(J)) CALL DS7IPR(P, IV(IPI), V(H1)) 300 IF (IV(MODEL) .EQ. 1) GO TO 310 LMAT1 = IV(LMAT) S1 = IV(S) CALL DV7CPY(P*(P+1)/2, V(LMAT1), V(S1)) CALL DS7IPR(P, IV(IPI), V(LMAT1)) CALL DV2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1)) 310 CALL DV7CPY(P, V(TD1), D) CALL DV7IPR(P, IV(IPI), V(TD1)) CALL DS7DMP(P1, V(H1), V(H1), V(TD1), -1) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 320 LMAT1 = IV(LMAT) CALL DG7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2), 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1), 2 V(TD1), V(TG1), V, V(W1), X, V(X01)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 330 IF (IV(IRC) .NE. 6) GO TO 340 IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 2 GO TO 370 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 340 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 360 IF (IV(IRC) .NE. 5) GO TO 350 IF (V(RADFAC) .LE. ONE) GO TO 350 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350 IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 0 GO TO 370 C C *** COMPUTE F(X0 + STEP) *** C 350 X01 = IV(X0) STEP1 = IV(STEP) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 360 RSTRST = 3 370 X01 = IV(X0) V(RELDX) = DRLDST(P, D, X, V(X01)) CALL DA7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = X01 + P I = IV(RESTOR) + 1 GO TO (410, 380, 390, 400), I 380 CALL DV7CPY(P, X, V(X01)) GO TO 410 390 CALL DV7CPY(P, V(LSTGST), V(STEP1)) GO TO 410 400 CALL DV7CPY(P, V(STEP1), V(LSTGST)) CALL DV2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = DRLDST(P, D, X, V(X01)) 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 CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X) L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL DS7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * DD7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 430 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 470 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL 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 = ABS(DD7TPR(PS, V(STEP1), V(TEMP1))) T = ABS(DD7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 550 CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 560 C 550 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL DV7CPY(P, V(G01), V(STEP1)) I = G01 + PS IF (PS .LT. P) CALL DV7SCP(P-PS, V(I), ZERO) CALL DV7IPR(P, IV(IPIV0), V(G01)) CALL DL7TVM(P, V(G01), V(RMAT1), V(G01)) CALL DL7VML(P, V(G01), V(RMAT1), V(G01)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL DV7IPR(P, IV(IPIV1), V(G01)) C 560 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 180 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 570 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 580 IF (IV(RDREQ) .EQ. 0) GO TO 660 IF (IV(FDH) .NE. 0) GO TO 660 IF (IV(CNVCOD) .GE. 7) GO TO 660 IF (IV(REGD) .GT. 0) GO TO 660 IF (IV(COVMAT) .GT. 0) GO TO 660 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 600 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 590 IV(RESTOR) = 0 600 CALL DF7DHB(B, D, G, I, IV, LIV, LV, P, V, X) GO TO (610, 620, 630), I 610 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C 620 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) GO TO 690 C 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120 GO TO 660 C 640 H1 = IABS(IV(H)) IV(FDH) = H1 IV(H) = -H1 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 650 CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1)) GO TO 660 650 RMAT1 = IV(RMAT) CALL DL7SQR(P, V(H1), V(RMAT1)) C 660 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 670 IV(1) = 1400 GO TO 999 C C *** INCONSISTENT B *** C 680 IV(1) = 82 GO TO 999 C C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G *** C 690 IV(1) = 2 J = IV(IPIVOT) IPI = IV(PERM) CALL I7PNVR(P, IV(IPI), IV(J)) DO 700 I = 1, P IV(J) = I J = J + 1 700 CONTINUE C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 710 DO 720 I = 1, P IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 720 CONTINUE IV(TOOBIG) = 0 C 999 RETURN C C *** LAST LINE OF DG7ITB FOLLOWS *** END SUBROUTINE DG7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV, 1 P, P0, PC, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) DOUBLE PRECISION B(2,P), D(P), DIHDI(1), G(P), L(1), 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2) C DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR,DG7QTS, DS7BQN, DS7IPR,DV7CPY, DV7IPR, 1 DV7SCP, DV7VMP C C *** LOCAL VARIABLES *** C INTEGER K, KB, KINIT, NS, P1, P10 DOUBLE PRECISION DS0, NRED, PRED, RAD DOUBLE PRECISION ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C 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 999 RETURN C *** LAST LINE OF DG7QSB FOLLOWS *** END SUBROUTINE DH2RFA(N, A, B, X, Y, Z) C C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO C *** N-VECTORS A, B *** C INTEGER N DOUBLE PRECISION A(N), B(N), X, Y, Z INTEGER I DOUBLE PRECISION T DO 10 I = 1, N T = A(I)*X + B(I)*Y A(I) = A(I) + T B(I) = B(I) + T*Z 10 CONTINUE 999 RETURN C *** LAST LINE OF DH2RFA FOLLOWS *** END DOUBLE PRECISION FUNCTION DH2RFG(A, B, X, Y, Z) C C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2 C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T, C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE DH2RFG C *** RETURNS. C DOUBLE PRECISION A, B, X, Y, Z C DOUBLE PRECISION A1, B1, C, T 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 = ABS(A) + ABS(B) A1 = A / T B1 = B / T C = SQRT(A1**2 + B1**2) IF (A1 .GT. ZERO) C = -C A1 = A1 - C Z = B1 / A1 X = A1 / C Y = B1 / C DH2RFG = T * C 999 RETURN C *** LAST LINE OF DH2RFG FOLLOWS *** END SUBROUTINE DL7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT, 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V, 2 W, WLM, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER IERR, KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) DOUBLE PRECISION B(2,P), D(P), G(P), LMAT(1), QTR(P), RMAT(1), 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(1), 2 X0(P), X(P) C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4) C DOUBLE PRECISION DD7TPR EXTERNAL DD7MLP, DD7TPR, DL7MST, DL7TVM, DQ7RSH, DS7BQN, 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP C C *** LOCAL VARIABLES *** C INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11 DOUBLE PRECISION DS0, NRED, PRED, RAD DOUBLE PRECISION ONE, ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C 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 50 IPIV1(I) = I K0 = MAX0(0, K) CALL DL7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP, 1 V, WLM) CALL DV7VMP(P1, TG, TG, TD, -1) P0 = P1 IF (KA .GE. 0) GO TO 60 NRED = V(NREDUC) DS0 = V(DST0) C 60 KA = K V(RADIUS) = RAD L = P1 + 5 IF (K .LE. K0) CALL DD7MLP(P1, LMAT, TD, RMAT, -1) IF (K .GT. K0) CALL DD7MLP(P1, LMAT, TD, WLM(L), -1) CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT, 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0) PRED = PRED + V(PREDUC) IF (NS .EQ. 0) GO TO 80 P0 = 0 C C *** UPDATE RMAT AND QTR *** C P11 = P1 + 1 L = P10 + P11 DO 70 K = P11, P10 J = L - K I = IPIV2(J) IF (I .LT. J) CALL DQ7RSH(I, J, .TRUE., QTR, RMAT, W) 70 CONTINUE C 80 IF (KB .GT. 0) GO TO 90 C C *** UPDATE LOCAL COPY OF QTR *** C CALL DV7VMP(P10, W, STEP(1,2), TD, -1) CALL DL7TVM(P10, W, LMAT, W) CALL DV2AXY(P10, STEP(1,3), ONE, W, QTR) GO TO 40 C 90 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = DD7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF DL7MSB FOLLOWS *** END SUBROUTINE DQ7RSH(K, P, HAVQTR, QTR, R, W) C C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY *** C LOGICAL HAVQTR INTEGER K, P DOUBLE PRECISION QTR(P), R(1), W(P) C DIMSNSION R(P*(P+1)/2) C DOUBLE PRECISION DH2RFG EXTERNAL DH2RFA, DH2RFG,DV7CPY C C *** LOCAL VARIABLES *** C INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1 DOUBLE PRECISION A, B, T, WJ, X, Y, Z, ZERO C DATA ZERO/0.0D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (K .GE. P) GO TO 999 KM1 = K - 1 K1 = K * KM1 / 2 CALL DV7CPY(K, W, R(K1+1)) WJ = W(K) PM1 = P - 1 J1 = K1 + KM1 DO 50 J = K, PM1 JM1 = J - 1 JP1 = J + 1 IF (JM1 .GT. 0) CALL DV7CPY(JM1, R(K1+1), R(J1+2)) J1 = J1 + JP1 K1 = K1 + J A = R(J1) B = R(J1+1) IF (B .NE. ZERO) GO TO 10 R(K1) = A X = ZERO Z = ZERO GO TO 40 10 R(K1) = DH2RFG(A, B, X, Y, Z) IF (J .EQ. PM1) GO TO 30 I1 = J1 DO 20 I = JP1, PM1 I1 = I1 + I CALL DH2RFA(1, R(I1), R(I1+1), X, Y, Z) 20 CONTINUE 30 IF (HAVQTR) CALL DH2RFA(1, QTR(J), QTR(JP1), X, Y, Z) 40 T = X * WJ W(J) = WJ + T WJ = T * Z 50 CONTINUE W(P) = WJ CALL DV7CPY(P, R(K1+1), W) 999 RETURN END SUBROUTINE DS7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS, 1 P, P1, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE BOUNDED MODIFIED NEWTON STEP *** C INTEGER KB, LV, NS, P, P1 INTEGER IPIV(P), IPIV1(P), IPIV2(P) DOUBLE PRECISION B(2,P), D(P), DST(P), L(1), 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P), 2 X0(P) C DIMENSION L(P*(P+1)/2) C DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM EXTERNAL DD7TPR, I7SHFT, DL7ITV, DL7IVM, DQ7RSH, DR7MDC, DV2NRM, 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7SHF C C *** LOCAL VARIABLES *** C INTEGER I, J, K, P0, P1M1 DOUBLE PRECISION ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T, 1 TI, T1, XI DOUBLE PRECISION FUDGE, HALF, MEPS2, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR C 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 20 W(I) = -STEP(I) * TD(I) ALPHA = ABS(V(STPPAR)) V(PREDUC) = ZERO GTS = -V(GTSTEP) IF (KB .LT. 0) CALL DV7SCP(P, DST, ZERO) KB = 1 C C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D. C C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE. C 30 T = ONE K = 0 DO 60 I = 1, P1 J = IPIV(I) DX = W(I) / D(J) XI = X(J) - DX IF (XI .LT. B(1,J)) GO TO 40 IF (XI .LE. B(2,J)) GO TO 60 TI = ( X(J) - B(2,J) ) / DX K = I GO TO 50 40 TI = ( X(J) - B(1,J) ) / DX K = -I 50 IF (T .LE. TI) GO TO 60 T = TI 60 CONTINUE C IF (P .GT. P1) CALL DV7CPY(P-P1, STEP(P1+1), DST(P1+1)) CALL DV2AXY(P1, STEP, -T, W, DST) DST0 = DST1 DST1 = DV2NRM(P, STEP) C C *** CHECK FOR OVERSIZE STEP *** C IF (DST1 .LE. DSTMAX) GO TO 80 IF (P1 .GE. P0) GO TO 70 IF (DST0 .LT. DSTMIN) KB = 0 GO TO 110 C 70 K = 0 C C *** UPDATE DST, TG, AND V(PREDUC) *** C 80 V(DSTNRM) = DST1 CALL DV7CPY(P1, DST, STEP) T1 = ONE - T DO 90 I = 1, P1 90 TG(I) = T1 * TG(I) IF (ALPHA .GT. ZERO) CALL DV2AXY(P1, TG, T*ALPHA, W, TG) V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS + 1 HALF*ALPHA*T*DD7TPR(P1,W,W)) IF (K .EQ. 0) GO TO 110 C C *** PERMUTE L, ETC. IF NECESSARY *** C P1M1 = P1 - 1 J = IABS(K) IF (J .EQ. P1) GO TO 100 NS = NS + 1 IPIV2(P1) = J CALL DQ7RSH(J, P1, .FALSE., TG, L, W) CALL I7SHFT(P1, J, IPIV) CALL I7SHFT(P1, J, IPIV1) CALL DV7SHF(P1, J, TG) CALL DV7SHF(P1, J, DST) 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1) P1 = P1M1 IF (P1 .LE. 0) GO TO 110 CALL DL7IVM(P1, W, L, TG) GTS = DD7TPR(P1, W, W) CALL DL7ITV(P1, W, L, W) GO TO 30 C C *** UNSCALE STEP *** C 110 DO 120 I = 1, P J = IABS(IPIV(I)) STEP(J) = DST(I) / D(J) 120 CONTINUE C C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS C *** TO THEIR BOUNDS *** C IF (P1 .GE. P0) GO TO 150 K = P1 + 1 DO 140 I = K, P0 J = IPIV(I) T = MEPS2 IF (J .GT. 0) GO TO 130 T = -T J = -J IPIV(I) = J 130 T = T * MAX( ABS(X(J)), ABS(X0(J))) STEP(J) = STEP(J) + T 140 CONTINUE C 150 CALL DV2AXY(P, X, ONE, STEP, X0) IF (NS .GT. 0) CALL DV7IPR(P0, IPIV1, TD) 999 RETURN C *** LAST LINE OF DS7BQN FOLLOWS *** END SUBROUTINE 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 LINE OF DS7DMP FOLLOWS *** END SUBROUTINE DS7IPR(P, IP, H) C C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H. C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)). C INTEGER P INTEGER IP(P) DOUBLE PRECISION H(1) C INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M DOUBLE PRECISION T C C *** BODY *** C DO 90 I = 1, P J = IP(I) IF (J .EQ. I) GO TO 90 IP(I) = IABS(J) IF (J .LT. 0) GO TO 90 K = I 10 J1 = J K1 = K IF (J .LE. K) GO TO 20 J1 = K K1 = J 20 KMJ = K1-J1 L = J1-1 JM = J1*L/2 KM = K1*(K1-1)/2 IF (L .LE. 0) GO TO 40 DO 30 M = 1, L JM = JM+1 T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 30 CONTINUE 40 KM = KM+1 KK = KM+KMJ JM = JM+1 T = H(JM) H(JM) = H(KK) H(KK) = T J1 = L L = KMJ-1 IF (L .LE. 0) GO TO 60 DO 50 M = 1, L JM = JM+J1+M T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 50 CONTINUE 60 IF (K1 .GE. P) GO TO 80 L = P-K1 K1 = K1-1 KM = KK DO 70 M = 1, L KM = KM+K1+M JM = KM-KMJ T = H(JM) H(JM) = H(KM) H(KM) = T 70 CONTINUE 80 K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 10 90 CONTINUE 999 RETURN C *** LAST LINE OF DS7IPR FOLLOWS *** END SUBROUTINE DV7IPR(N, IP, X) C C PERMUTE X SO THAT X.OUTPUT(I) = X.INPUT(IP(I)). C IP IS UNCHANGED ON OUTPUT. C INTEGER N INTEGER IP(N) DOUBLE PRECISION X(N) C INTEGER I, J, K DOUBLE PRECISION T DO 30 I = 1, N J = IP(I) IF (J .EQ. I) GO TO 30 IF (J .GT. 0) GO TO 10 IP(I) = -J GO TO 30 10 T = X(I) K = I 20 X(K) = X(J) K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 20 X(K) = T 30 CONTINUE 999 RETURN C *** LAST LINE OF DV7IPR FOLLOWS *** END SUBROUTINE DV7SHF(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION *** C INTEGER N, K DOUBLE PRECISION X(N) C INTEGER I, NM1 DOUBLE PRECISION T C IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T 999 RETURN END SUBROUTINE DV7VMP(N, X, Y, Z, K) C C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) *** C INTEGER N, K DOUBLE PRECISION X(N), Y(N), Z(N) INTEGER I C IF (K .GE. 0) GO TO 20 DO 10 I = 1, N 10 X(I) = Y(I) / Z(I) GO TO 999 C 20 DO 30 I = 1, N 30 X(I) = Y(I) * Z(I) 999 RETURN C *** LAST LINE OF DV7VMP FOLLOWS *** END SUBROUTINE I7COPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE INTEGER P-VECTORS *** C INTEGER P INTEGER X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) 999 RETURN END SUBROUTINE I7PNVR(N, X, Y) C C *** SET PERMUTATION VECTOR X TO INVERSE OF Y *** C INTEGER N INTEGER X(N), Y(N) C INTEGER I, J DO 10 I = 1, N J = Y(I) X(J) = I 10 CONTINUE C 999 RETURN C *** LAST LINE OF I7PNVR FOLLOWS *** END SUBROUTINE I7SHFT(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION *** C INTEGER N, K INTEGER X(N) C INTEGER I, NM1, T C IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T 999 RETURN END //GO.SYSIN DD dglfgb.f cat >dgletc.f <<'//GO.SYSIN DD dgletc.f' 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 EVAULATE 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 PRECDENCE 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) (IN) IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED C OVERFLOW). 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 CONVERVENCE 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 EXECPT 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) 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 110 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 110 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 110, 110, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 IV(RESTOR) = 1 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 IV(RESTOR) = 1 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) NFC = IV(NFGCAL) GOODX = .FALSE. 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 * MAX(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 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) = MAX(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) .NE. 1) IV(RESTOR) = 2 V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 230 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 210 V(RADFAC) = ONE IV(IRC) = 3 GO TO 230 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 220 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 240 IV(IRC) = 12 GO TO 240 C C *** PERFORM CONVERGENCE TESTS *** C 230 IV(XIRC) = IV(IRC) 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3 IF ( ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = V(RFCTOL) * ABS(V(F0)) EMAXS = V(SCTOL) * ABS(V(F0)) IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR. 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 250 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL) 1 .AND. GOODX) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR C *** CONVERGENCE TEST. C 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(STPPAR) .EQ. ZERO) GO TO 999 IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260 IF (V(PREDUC) .GE. EMAXS) GO TO 999 IF (V(DST0) .LE. ZERO) GO TO 270 IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999 GO TO 270 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999 XMAX = V(LMAXS) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999 270 IF (V(NREDUC) .LT. ZERO) GO TO 290 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) I = IV(RESTOR) IV(RESTOR) = 2 IF (I .EQ. 3) IV(RESTOR) = 0 IV(IRC) = 6 GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 280 V(GTSTEP) = V(GTSLST) V(DSTNRM) = ABS(V(DSTSAV)) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) IV(RESTOR) = 3 290 IF (-V(NREDUC) .LE. V(SCTOL) * ABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST LINE OF DA7SST FOLLOWS *** END DOUBLE PRECISION FUNCTION DD7TPR(P, X, Y) C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C INTEGER P DOUBLE PRECISION X(P), Y(P) C INTEGER I DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C *** ACTIVATE THE *'ED COMMENT LINES BELOW IF UNDERFLOW IS A PROBLEM. C *** DR7MDC(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C DOUBLE PRECISION ONE, ZERO PARAMETER (ONE=1.D+0, ZERO=0.D+0) * DOUBLE PRECISION SQTETA, T * DATA SQTETA/0.D+0/ C DD7TPR = ZERO * IF (P .LE. 0) GO TO 999 * IF (SQTETA .EQ. ZERO) SQTETA = DR7MDC(2) DO 20 I = 1, P * T = DMAX1(DABS(X(I)), DABS(Y(I))) * IF (T .GT. ONE) GO TO 10 * IF (T .LT. SQTETA) GO TO 20 * T = (X(I)/SQTETA)*Y(I) * IF (DABS(T) .LT. SQTETA) GO TO 20 10 DD7TPR = DD7TPR + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST LINE OF DD7TPR FOLLOWS *** END SUBROUTINE DD7UP5(D, IV, LIV, LV, P, PS, V) C C *** UPDATE SCALE VECTOR D FOR DG7LIT *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) DOUBLE PRECISION D(P), V(LV) C C *** LOCAL VARIABLES *** C INTEGER D0, HII, I, JTOLI, JTOL0, R1I, S1 DOUBLE PRECISION T, VDFAC C C *** CONSTANTS *** DOUBLE PRECISION ZERO C C *** EXTERNAL FUNCTIONS *** C EXTERNAL DD7TPR DOUBLE PRECISION DD7TPR C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTYPE, HC, JTOL, NITER, RMAT, S PARAMETER (DFAC=41, DTYPE=16, HC=71, JTOL=59, NITER=31, RMAT=78, 1 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 R1I = IV(RMAT) HII = IV(HC) - 1 VDFAC = V(DFAC) JTOL0 = IV(JTOL) - 1 D0 = JTOL0 + P S1 = IV(S) - 1 DO 30 I = 1, P IF (R1I .LE. 0) GO TO 10 T = DD7TPR(I, V(R1I), V(R1I)) R1I = R1I + I GO TO 20 10 HII = HII + I T = ABS(V(HII)) 20 S1 = S1 + I IF (I .LE. PS) T = T + MAX(V(S1), ZERO) T = SQRT(T) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = MAX(V(D0), V(JTOLI)) D(I) = MAX(VDFAC*D(I), T) 30 CONTINUE C 999 RETURN C *** LAST LINE OF DD7UP5 FOLLOWS *** END SUBROUTINE DG7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W) C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN *** C C *** PARAMETER DECLARATIONS *** C INTEGER KA, P DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C (DG7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT C CALL THIS ROUTINE. C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C DL7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C DL7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DL7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C DL7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C DR7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS. C DV2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB. C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL RESTRT INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK, 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ, 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI C C *** CONSTANTS *** DOUBLE PRECISION BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, 1 ONE, P001, SIX, THREE, TWO, ZERO C C *** 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* MIN(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 = ABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 20 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 30 CALL DL7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 50 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 40 I = 1, IRC 40 W(I) = ZERO W(IRC) = ONE CALL DL7ITV(IRC, W, L, W) T1 = DV2NRM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 50 LK = ZERO T = DL7SVN(P, L, W(Q), W(Q)) IF (T .GE. ONE) GO TO 60 IF (V(DGNORM) .GE. T*T*BIG) GO TO 70 60 CALL DL7IVM(P, W(Q), L, DIG) GTSTA = DD7TPR(P, W(Q), W(Q)) V(NREDUC) = HALF * GTSTA CALL DL7ITV(P, W(Q), L, W(Q)) DST = DV2NRM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 260 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = ABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = MAX(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = MIN(UK, MAX(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 = MAX(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 * MAX(P001, SQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK IF (ALPHAK .LE. ZERO) ALPHAK = UK K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL DL7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 240 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL DL7ITV(IRC, W, L, W) T1 = DV2NRM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK IF (UK .LT. LK) UK = LK IF (ALPHAK .LT. LK) GO TO 210 C C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK... C T = P001 * ALPHAK IF (T .LE. ZERO) T = P001 LK = ALPHAK + T IF (UK .LE. LK) UK = LK + T GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 240 CALL DL7IVM(P, W(Q), L, DIG) GTSTA = DD7TPR(P, W(Q), W(Q)) CALL DL7ITV(P, W(Q), L, W(Q)) DST = DV2NRM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270 IF (PHI .EQ. OLDPHI) GO TO 270 OLDPHI = PHI IF (PHI .LT. ZERO) GO TO 330 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 250 IF (KA .GE. KALIM) GO TO 270 C *** THE FOLLOWING MIN IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = MIN(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 = MAX(LK, ALPHAK) ALPHAK = LK GO TO 210 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 260 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 270 DO 280 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 280 CONTINUE V(GTSTEP) = -GTSTA V(PREDUC) = HALF * ( ABS(ALPHAK)*DST*DST + GTSTA) GO TO 410 C C C *** RESTART WITH NEW RADIUS *** C 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 300 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 300 CONTINUE UK = NEGONE GO TO 30 C 310 KAMIN = KA + 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 IF (KA .EQ. 0) GO TO 50 C DST = W(DSTSAV) ALPHAK = ABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD UK = T - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 IF (RAD .GT. V(RAD0)) GO TO 320 C C *** SMALLER RADIUS *** LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = MAX(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 250 C C *** BIGGER RADIUS *** 320 IF (ALPHAK .GT. ZERO) UK = MIN(UK, W(UK0)) LK = MAX(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = MAX(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 + MIN(ZERO, V(DST0)) TWOPSI = ALPHAK*DST*DST + GTSTA IF (KA .GE. KAMIN) GO TO 340 C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS C *** IT). IF (PSIFAC .GE. BIG) GO TO 340 IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370 C C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. USE ONE STEP OF INVERSE POWER METHOD WITH START C *** FROM DL7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). DL7SVN RETURNS C *** X AND W WITH L*W = X. C 340 T = DL7SVN(P, L, W(X), W) C C *** NORMALIZE W *** DO 350 I = 1, P 350 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL DL7ITV(P, W, L, W) T2 = ONE/DV2NRM(P, W) DO 360 I = 1, P 360 W(I) = T2*W(I) T = T2 * T C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = DD7TPR(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = SQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C C *** THE ACTUAL TEST FOR THE SPECIAL CASE... C IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380 C C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE) C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE... C IF (V(DST0) .LE. ZERO) V(DST0) = MIN(V(DST0), T2**2 - ALPHAK) LK = MAX(LK, -V(DST0)) C C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT. C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * DR7MDC(3) C IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250 GO TO 270 C C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE C 380 ALPHAK = -ALPHAK V(PREDUC) = HALF * TWOPSI C C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. C T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DD7TPR(P,W(X),W))) IF (T .LT. EPS*TWOPSI/SIX) GO TO 390 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 390 DO 400 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 400 CONTINUE V(GTSTEP) = DD7TPR(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 410 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 420 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 420 CONTINUE C 999 RETURN C C *** LAST LINE OF DG7QTS FOLLOWS *** END SUBROUTINE DITSUM(D, G, IV, LIV, LV, P, V, X) C C *** PRINT ITERATION SUMMARY FOR ***SOL (VERSION 2.3) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P INTEGER IV(LIV) DOUBLE PRECISION D(P), G(P), V(LV), X(P) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER ALG, I, IV1, M, NF, NG, OL, PU CHARACTER*4 MODEL1(6), MODEL2(6) DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO C C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER ALGSAV, DSTNRM, F, FDIF, F0, NEEDHD, NFCALL, NFCOV, NGCOV, 1 NGCALL, NITER, NREDUC, OUTLEV, PREDUC, PRNTIT, PRUNIT, 2 RELDX, SOLPRT, STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C PARAMETER (ALGSAV=51, NEEDHD=36, NFCALL=6, NFCOV=52, NGCALL=30, 1 NGCOV=53, NITER=31, OUTLEV=19, PRNTIT=39, PRUNIT=21, 2 SOLPRT=22, STATPR=23, SUSED=64, X0PRT=24) C C *** V SUBSCRIPT VALUES *** C PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, PREDUC=7, 1 RELDX=17, STPPAR=5) C PARAMETER (ZERO=0.D+0) DATA MODEL1/' ',' ',' ',' ',' G ',' S '/, 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/ C C------------------------------- BODY -------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IV1 = IV(1) IF (IV1 .GT. 62) IV1 = IV1 - 51 OL = IV(OUTLEV) ALG = MOD(IV(ALGSAV)-1,2) + 1 IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 370 IF (IV1 .GE. 12) GO TO 120 IF (IV1 .EQ. 2 .AND. IV(NITER) .EQ. 0) GO TO 390 IF (OL .EQ. 0) GO TO 120 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 120 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999 10 NF = IV(NFCALL) - IABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = MAX( ABS(V(F0)), ABS(V(F))) IF (OLDF .LE. ZERO) GO TO 20 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 20 IF (OL .GT. 0) GO TO 60 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,30) 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,40) 40 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR) IV(NEEDHD) = 0 IF (ALG .EQ. 2) GO TO 50 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR) GO TO 120 C 50 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 V(STPPAR) GO TO 120 C C *** PRINT LONG SUMMARY LINE *** C 60 IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,70) 70 FORMAT(/11H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR,2X,6HD*STEP,2X,7HNPRELDF) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,80) 80 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR,3X,6HD*STEP,3X,7HNPRELDF) IV(NEEDHD) = 0 NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF IF (ALG .EQ. 2) GO TO 90 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR), V(DSTNRM), NRELDF GO TO 120 C 90 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, 1 V(RELDX), V(STPPAR), V(DSTNRM), NRELDF 100 FORMAT(I6,I5,E10.3,2E9.2,E8.1,A3,A4,2E8.1,E9.2) 110 FORMAT(I6,I5,E11.3,2E10.2,3E9.1,E10.2) C 120 IF (IV1 .LE. 2) GO TO 999 I = IV(STATPR) IF (I .EQ. (-1)) GO TO 460 IF (I + IV1 .LT. 0) GO TO 460 GO TO (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, 1 330, 350, 500), IV1 C 130 WRITE(PU,140) 140 FORMAT(/26H ***** X-CONVERGENCE *****) GO TO 430 C 150 WRITE(PU,160) 160 FORMAT(/42H ***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 170 WRITE(PU,180) 180 FORMAT(/49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 190 WRITE(PU,200) 200 FORMAT(/42H ***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 430 C 210 WRITE(PU,220) 220 FORMAT(/33H ***** SINGULAR CONVERGENCE *****) GO TO 430 C 230 WRITE(PU,240) 240 FORMAT(/30H ***** FALSE CONVERGENCE *****) GO TO 430 C 250 WRITE(PU,260) 260 FORMAT(/38H ***** FUNCTION EVALUATION LIMIT *****) GO TO 430 C 270 WRITE(PU,280) 280 FORMAT(/28H ***** ITERATION LIMIT *****) GO TO 430 C 290 WRITE(PU,300) 300 FORMAT(/18H ***** STOPX *****) GO TO 430 C 310 WRITE(PU,320) 320 FORMAT(/44H ***** INITIAL F(X) CANNOT BE COMPUTED *****) C GO TO 390 C 330 WRITE(PU,340) 340 FORMAT(/37H ***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 350 WRITE(PU,360) 360 FORMAT(/43H ***** GRADIENT COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 460 GO TO 390 C 370 WRITE(PU,380) IV(1) 380 FORMAT(/14H ***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON DITSUM *** C 390 IF (IV(X0PRT) .NE. 0) WRITE(PU,400) (I, X(I), D(I), I = 1, P) 400 FORMAT(/23H I INITIAL X(I),8X,4HD(I)//(1X,I5,E17.6,E14.3)) C *** THE FOLLOWING ARE TO AVOID UNDEFINED VARIABLES WHEN THE C *** FUNCTION EVALUATION LIMIT IS 1... V(DSTNRM) = ZERO V(FDIF) = ZERO V(NREDUC) = ZERO V(PREDUC) = ZERO V(RELDX) = ZERO IF (IV1 .GE. 12) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0 .AND. ALG .EQ. 1) WRITE(PU,30) IF (OL .LT. 0 .AND. ALG .EQ. 2) WRITE(PU,40) IF (OL .GT. 0 .AND. ALG .EQ. 1) WRITE(PU,70) IF (OL .GT. 0 .AND. ALG .EQ. 2) WRITE(PU,80) IF (ALG .EQ. 1) WRITE(PU,410) IV(NFCALL), V(F) IF (ALG .EQ. 2) WRITE(PU,420) IV(NFCALL), V(F) 410 FORMAT(/6H 0,I5,E10.3) 420 FORMAT(/6H 0,I5,E11.3) GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 430 IV(NEEDHD) = 1 IF (IV(STATPR) .LE. 0) GO TO 460 OLDF = MAX( ABS(V(F0)), ABS(V(F))) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 440 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 440 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(PU,450) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 450 FORMAT(/9H FUNCTION,E17.6,8H RELDX,E17.3/12H FUNC. EVALS, 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,E16.3,6X,7HNPRELDF,E15.3) C 460 IF (IV(SOLPRT) .EQ. 0) GO TO 999 IV(NEEDHD) = 1 IF (IV(ALGSAV) .GT. 2) GO TO 999 WRITE(PU,470) 470 FORMAT(/22H I FINAL X(I),8X,4HD(I),10X,4HG(I)/) DO 480 I = 1, P 480 WRITE(PU,490) I, X(I), D(I), G(I) 490 FORMAT(1X,I5,E16.6,2E14.3) GO TO 999 C 500 WRITE(PU,510) 510 FORMAT(/24H INCONSISTENT DIMENSIONS) 999 RETURN C *** LAST LINE OF DITSUM FOLLOWS *** END SUBROUTINE DIVSET(ALG, IV, LIV, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER LIV, LV INTEGER ALG, IV(LIV) DOUBLE PRECISION V(LV) C INTEGER I7MDCN EXTERNAL I7MDCN,DV7DFL C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS. C DV7DFL.... PROVIDES DEFAULT VALUES TO V. C INTEGER ALG1, MIV, MV INTEGER MINIV(4), MINV(4) C C *** SUBSCRIPTS FOR IV *** C INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH, 1 INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL, 2 MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT, 3 PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR, 4 VNEED, VSAVE, X0PRT C C *** IV SUBSCRIPT VALUES *** C PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16, 1 HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76, 2 IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17, 3 MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9, 4 OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21, 5 QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23, 6 VNEED=4, VSAVE=60, X0PRT=24) DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/, 1 MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/ C C------------------------------- BODY -------------------------------- C IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1) IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40 MIV = MINIV(ALG) IF (LIV .LT. MIV) GO TO 20 MV = MINV(ALG) IF (LV .LT. MV) GO TO 30 ALG1 = MOD(ALG-1,2) + 1 CALL DV7DFL(ALG1, LV, V) IV(1) = 12 IF (ALG .GT. 2) IV(DRADPR) = 1 IV(IVNEED) = 0 IV(LASTIV) = MIV IV(LASTV) = MV IV(LMAT) = MV + 1 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PERM) = MIV + 1 IV(SOLPRT) = 1 IV(STATPR) = 1 IV(VNEED) = 0 IV(X0PRT) = 1 C IF (ALG1 .GE. 2) GO TO 10 C C *** REGRESSION VALUES C IV(COVPRT) = 3 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(HC) = 0 IV(IERR) = 0 IV(INITS) = 0 IV(IPIVOT) = 0 IV(NVDFLT) = 32 IV(VSAVE) = 58 IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3 IV(PARSAV) = IV(VSAVE) + NVSAVE IV(QRTYP) = 1 IV(RDREQ) = 3 IV(RMAT) = 0 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 IV(DTYPE) = 0 IV(INITH) = 1 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(NVDFLT) = 25 IV(PARSAV) = 47 IF (ALG .GT. 2) IV(PARSAV) = 61 GO TO 999 C 20 IV(1) = 15 GO TO 999 C 30 IV(1) = 16 GO TO 999 C 40 IV(1) = 67 C 999 RETURN C *** LAST LINE OF DIVSET FOLLOWS *** END SUBROUTINE DL7ITV(N, X, L, Y) C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 DOUBLE PRECISION XI, ZERO PARAMETER (ZERO=0.D+0) C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST LINE OF DL7ITV FOLLOWS *** END SUBROUTINE DL7IVM(N, X, L, Y) C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) DOUBLE PRECISION DD7TPR EXTERNAL DD7TPR INTEGER I, J, K DOUBLE PRECISION T, ZERO 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 LINE OF DL7IVM FOLLOWS *** END SUBROUTINE DL7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, KA, P INTEGER IPIVOT(P) DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR DQ7RGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR DQ7RGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C DL7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C DL7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C DL7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C DV7CPY - COPIES ONE VECTOR TO ANOTHER. C DV2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, 1 TTOL, ZERO DOUBLE PRECISION BIG C C *** 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) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 V(NREDUC) = HALF*DD7TPR(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 T = DL7SVN(P, R, STEP, W(RES)) IF (T .GE. ONE) GO TO 30 IF (DV2NRM(P, QTR) .GE. BIG*T) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING DL7ITV AND DL7IVM. 30 CALL DL7ITV(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = DV2NRM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL DL7IVM(P, STEP, R, STEP) T = ONE / DV2NRM(P, STEP) W(PHIPIN) = (T/RAD)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = DV2NRM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. C ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = MIN(UK, MAX(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 * MAX(P001, SQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK SQRTAK = SQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. ABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P L = I1*(I1+1)/2 + RMAT0 WL = W(L) SI = STEP(I1-1) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF ( ABS(SI) .GT. ABS(WL)) GO TO 220 IF (SI .EQ. ZERO) GO TO 260 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL DL7ITV(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = DV2NRM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - DD7TPR(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL DL7IVM(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / SQRT(W(I)) T = ONE / DV2NRM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = MAX(LK, ALPHAK) ALPHAK = LK GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = ABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = MAX(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 = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = MIN(DD7TPR(P,STEP,G), ZERO) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C 999 RETURN C C *** LAST LINE OF DL7MST FOLLOWS *** END SUBROUTINE DL7SQR(N, A, L) C C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE C *** SAME STORAGE. C C *** PARAMETERS *** C INTEGER N DOUBLE PRECISION A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1 DOUBLE PRECISION T C NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II IP1 = I + 1 I0 = I0 - I J0 = I*(I+1)/2 DO 20 JJ = 1, I J = IP1 - JJ J0 = J0 - J T = 0.0D0 DO 10 K = 1, J IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE IJ = I0 + J A(IJ) = T 20 CONTINUE 30 CONTINUE 999 RETURN END SUBROUTINE DL7SRT(N1, N, L, A, IRC) C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C *** PARAMETERS *** C INTEGER N1, N, IRC DOUBLE PRECISION L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K DOUBLE PRECISION T, TD, ZERO C 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) = SQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST LINE OF DL7SRT *** END DOUBLE PRECISION FUNCTION DL7SVN(P, L, X, Y) C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF DL7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF DL7SVN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO DL7SVN RETURNS). C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C DL7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1 DOUBLE PRECISION B, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C DOUBLE PRECISION HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DD7TPR, DV2NRM,DV2AXY C 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 + FLOAT(IX)/R9973) XPLUS = B / L(JJ) X(P) = XPLUS IF (P .LE. 1) GO TO 60 DO 10 I = 1, PM1 II = II + I IF (L(II) .EQ. ZERO) GO TO 110 JI = J0 + I X(I) = XPLUS * L(JI) 10 CONTINUE C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 50 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = ABS(XPLUS) SMINUS = ABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .GT. 0) CALL DV2AXY(JM1, X, XPLUS, L(J0+1), X) 50 CONTINUE C C *** NORMALIZE X *** C 60 T = ONE/DV2NRM(P, X) DO 70 I = 1, P 70 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN DL7SVN = 1/TWONORM(Y) *** C DO 100 J = 1, P JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J T = ZERO IF (JM1 .GT. 0) T = DD7TPR(JM1, L(J0+1), Y) Y(J) = (X(J) - T) / L(JJ) 100 CONTINUE C DL7SVN = ONE/DV2NRM(P, Y) GO TO 999 C 110 DL7SVN = ZERO 999 RETURN C *** LAST LINE OF DL7SVN FOLLOWS *** END DOUBLE PRECISION FUNCTION DL7SVX(P, L, X, Y) C C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS C APPROXIMATION MAY BE CRUDE. C Y (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND- C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X C OVER-WRITES Y. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1 DOUBLE PRECISION B, BLJI, SMINUS, SPLUS, T, YI C C *** CONSTANTS *** C DOUBLE PRECISION HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DD7TPR, DV2NRM,DV2AXY C 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 + FLOAT(IX)/R9973) X(P) = B * L(JJ) IF (P .LE. 1) GO TO 40 DO 10 I = 1, PM1 JI = J0 + I X(I) = B * L(JI) 10 CONTINUE C C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 30 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) JM1 = J - 1 J0 = J*JM1/2 SPLUS = ZERO SMINUS = ZERO DO 20 I = 1, J JI = J0 + I BLJI = B * L(JI) SPLUS = SPLUS + ABS(BLJI + X(I)) SMINUS = SMINUS + ABS(BLJI - X(I)) 20 CONTINUE IF (SMINUS .GT. SPLUS) B = -B X(J) = ZERO C *** UPDATE PARTIAL SUMS *** CALL DV2AXY(J, X, B, L(J0+1), X) 30 CONTINUE C C *** NORMALIZE X *** C 40 T = DV2NRM(P, X) IF (T .LE. ZERO) GO TO 80 T = ONE / T DO 50 I = 1, P 50 X(I) = T*X(I) C C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) *** C DO 60 JJJ = 1, P J = PPLUS1 - JJJ JI = J*(J-1)/2 + 1 Y(J) = DD7TPR(J, L(JI), X) 60 CONTINUE C C *** NORMALIZE Y AND SET X = (L**T)*Y *** C T = ONE / DV2NRM(P, Y) JI = 1 DO 70 I = 1, P YI = T * Y(I) X(I) = ZERO CALL DV2AXY(I, X, YI, L(JI), X) JI = JI + I 70 CONTINUE DL7SVX = DV2NRM(P, X) GO TO 999 C 80 DL7SVX = ZERO C 999 RETURN C *** LAST LINE OF DL7SVX FOLLOWS *** END SUBROUTINE DL7TVM(N, X, L, Y) C C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY C *** OCCUPY THE SAME STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, IJ, I0, J DOUBLE PRECISION YI, ZERO 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 999 RETURN C *** LAST LINE OF DL7TVM FOLLOWS *** END SUBROUTINE DL7VML(N, X, L, Y) C C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, II, IJ, I0, J, NP1 DOUBLE PRECISION T, ZERO 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 999 RETURN C *** LAST LINE OF DL7VML FOLLOWS *** END SUBROUTINE DO7PRD(L, LS, P, S, W, Y, Z) C C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E., C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I). C INTEGER L, LS, P DOUBLE PRECISION S(LS), W(L), Y(P,L), Z(P,L) C DIMENSION S(P*(P+1)/2) C INTEGER I, J, K, M DOUBLE PRECISION WK, YI, ZERO DATA ZERO/0.D+0/ C DO 30 K = 1, L WK = W(K) IF (WK .EQ. ZERO) GO TO 30 M = 1 DO 20 I = 1, P YI = WK * Y(I,K) DO 10 J = 1, I S(M) = S(M) + YI*Z(J,K) M = M + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE C 999 RETURN C *** LAST LINE OF DO7PRD 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*1 VARNM(2), SH(2) CHARACTER*4 CNGD(3), DFLT(3), VN(2,34), 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/ DATA VN(1,1),VN(2,1)/'EPSL','ON..'/ DATA VN(1,2),VN(2,2)/'PHMN','FC..'/ DATA VN(1,3),VN(2,3)/'PHMX','FC..'/ DATA VN(1,4),VN(2,4)/'DECF','AC..'/ DATA VN(1,5),VN(2,5)/'INCF','AC..'/ DATA VN(1,6),VN(2,6)/'RDFC','MN..'/ DATA VN(1,7),VN(2,7)/'RDFC','MX..'/ DATA VN(1,8),VN(2,8)/'TUNE','R1..'/ DATA VN(1,9),VN(2,9)/'TUNE','R2..'/ DATA VN(1,10),VN(2,10)/'TUNE','R3..'/ DATA VN(1,11),VN(2,11)/'TUNE','R4..'/ DATA VN(1,12),VN(2,12)/'TUNE','R5..'/ DATA VN(1,13),VN(2,13)/'AFCT','OL..'/ DATA VN(1,14),VN(2,14)/'RFCT','OL..'/ DATA VN(1,15),VN(2,15)/'XCTO','L...'/ DATA VN(1,16),VN(2,16)/'XFTO','L...'/ DATA VN(1,17),VN(2,17)/'LMAX','0...'/ DATA VN(1,18),VN(2,18)/'LMAX','S...'/ DATA VN(1,19),VN(2,19)/'SCTO','L...'/ DATA VN(1,20),VN(2,20)/'DINI','T...'/ DATA VN(1,21),VN(2,21)/'DTIN','IT..'/ DATA VN(1,22),VN(2,22)/'D0IN','IT..'/ DATA VN(1,23),VN(2,23)/'DFAC','....'/ DATA VN(1,24),VN(2,24)/'DLTF','DC..'/ DATA VN(1,25),VN(2,25)/'DLTF','DJ..'/ DATA VN(1,26),VN(2,26)/'DELT','A0..'/ DATA VN(1,27),VN(2,27)/'FUZZ','....'/ DATA VN(1,28),VN(2,28)/'RLIM','IT..'/ DATA VN(1,29),VN(2,29)/'COSM','IN..'/ DATA VN(1,30),VN(2,30)/'HUBE','RC..'/ DATA VN(1,31),VN(2,31)/'RSPT','OL..'/ DATA VN(1,32),VN(2,32)/'SIGM','IN..'/ DATA VN(1,33),VN(2,33)/'ETA0','....'/ DATA VN(1,34),VN(2,34)/'BIAS','....'/ C 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 VARNM(1)/'P'/, VARNM(2)/'P'/, SH(1)/'S'/, SH(2)/'H'/ DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/, 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/ C C............................... BODY ................................ C PU = 0 IF (PRUNIT .LE. LIV) PU = IV(PRUNIT) IF (ALGSAV .GT. LIV) GO TO 20 IF (ALG .EQ. IV(ALGSAV)) GO TO 20 IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV) 10 FORMAT(/40H THE FIRST PARAMETER TO DIVSET SHOULD BE,I3, 1 12H RATHER THAN,I3) IV(1) = 67 GO TO 999 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340 MIV1 = MINIV(ALG) IF (IV(1) .EQ. 15) GO TO 360 ALG1 = MOD(ALG-1,2) + 1 IF (IV(1) .EQ. 0) CALL DIVSET(ALG, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30 IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1) IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2 IF (LIV .LT. MIV1) GO TO 300 IV(IVNEED) = 0 IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1 IV(VNEED) = 0 IF (LIV .LT. MIV2) GO TO 300 IF (LV .LT. IV(LASTV)) GO TO 320 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60 IF (N .GE. 1) GO TO 50 IV(1) = 81 IF (PU .EQ. 0) GO TO 999 WRITE(PU,40) VARNM(ALG1), N 40 FORMAT(/8H /// BAD,A1,2H =,I5) GO TO 999 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM) IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT) IF (IV1 .EQ. 13) GO TO 999 K = IV(PARSAV) - EPSLON CALL DV7DFL(ALG1, LV-K, V(K+1)) IV(DTYPE0) = 2 - ALG1 IV(OLDN) = N WHICH(1) = DFLT(1) WHICH(2) = DFLT(2) WHICH(3) = DFLT(3) GO TO 110 60 IF (N .EQ. IV(OLDN)) GO TO 80 IV(1) = 17 IF (PU .EQ. 0) GO TO 999 WRITE(PU,70) VARNM(ALG1), IV(OLDN), N 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5) GO TO 999 C 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100 IV(1) = 80 IF (PU .NE. 0) WRITE(PU,90) IV1 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.) GO TO 999 C 100 WHICH(1) = CNGD(1) WHICH(2) = CNGD(2) WHICH(3) = CNGD(3) C 110 IF (IV1 .EQ. 14) IV1 = 12 IF (BIG .GT. TINY) GO TO 120 TINY = DR7MDC(1) MACHEP = DR7MDC(3) BIG = DR7MDC(6) VM(12) = MACHEP VX(12) = BIG VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = TINY VX(18) = BIG VX(20) = BIG VX(21) = BIG VX(22) = BIG VM(24) = MACHEP VM(25) = MACHEP VM(26) = MACHEP VX(28) = DR7MDC(5) VM(29) = MACHEP VX(30) = BIG VM(33) = MACHEP 120 M = 0 I = 1 J = JLIM(ALG1) K = EPSLON NDFALT = NDFLT(ALG1) DO 150 L = 1, NDFALT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140 M = K IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK, 1 VM(I), VX(I) 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,E11.3,7H SHOULD, 1 11H BE BETWEEN,E11.3,4H AND,E11.3) 140 K = K + 1 I = I + 1 IF (I .EQ. J) I = IJMP 150 CONTINUE C IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170 IV(1) = 51 IF (PU .EQ. 0) GO TO 999 WRITE(PU,160) IV(NVDFLT), NDFALT 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5) GO TO 999 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12) 1 GO TO 200 DO 190 I = 1, N IF (D(I) .GT. ZERO) GO TO 190 M = 18 IF (PU .NE. 0) WRITE(PU,180) I, D(I) 180 FORMAT(/8H /// D(,I3,3H) =,E11.3,19H SHOULD BE POSITIVE) 190 CONTINUE 200 IF (M .EQ. 0) GO TO 210 IV(1) = M GO TO 999 C 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230 M = 1 WRITE(PU,220) SH(ALG1), IV(INITS) 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =, 1 I3) 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250 IF (M .EQ. 0) WRITE(PU,260) WHICH M = 1 WRITE(PU,240) IV(DTYPE) 240 FORMAT(20H DTYPE..... IV(16) =,I3) 250 I = 1 J = JLIM(ALG1) K = EPSLON L = IV(PARSAV) NDFALT = NDFLT(ALG1) DO 290 II = 1, NDFALT IF (V(K) .EQ. V(L)) GO TO 280 IF (M .EQ. 0) WRITE(PU,260) WHICH 260 FORMAT(/1H ,3A4,9HALUES..../) M = 1 WRITE(PU,270) VN(1,I), VN(2,I), K, V(K) 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,E15.7) 280 K = K + 1 L = L + 1 I = I + 1 IF (I .EQ. J) I = IJMP 290 CONTINUE C IV(DTYPE0) = IV(DTYPE) PARSV1 = IV(PARSAV) CALL DV7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON)) GO TO 999 C 300 IV(1) = 15 IF (PU .EQ. 0) GO TO 999 WRITE(PU,310) LIV, MIV2 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5) IF (LIV .LT. MIV1) GO TO 999 IF (LV .LT. IV(LASTV)) GO TO 320 GO TO 999 C 320 IV(1) = 16 IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV) 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5) GO TO 999 C 340 IV(1) = 67 IF (PU .NE. 0) WRITE(PU,350) ALG 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4) GO TO 999 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5, 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1 IF (LASTV .LE. LIV) IV(LASTV) = 0 C 999 RETURN C *** LAST LINE OF DPARCK FOLLOWS *** END SUBROUTINE DQ7ADR(P, QTR, RMAT, W, Y) C C *** ADD ROW W TO QR FACTORIZATION WITH R MATRIX RMAT AND C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENT OF RESIDUAL C *** CORRESPONDING TO W. C INTEGER P DOUBLE PRECISION QTR(P), RMAT(1), W(P), Y C DIMENSION RMAT(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IP1, J DOUBLE PRECISION RI, RW, T, U1, U2, V, WI, WR C DOUBLE PRECISION ONE, ZERO PARAMETER (ONE=1.D+0, ZERO=0.D+0) C C------------------------------ BODY ----------------------------------- C II = 0 DO 60 I = 1, P II = II+I WI = W(I) IF (WI .EQ. ZERO) GOTO 60 RI = RMAT(II) IF (RI .NE. ZERO) GOTO 20 IJ = II C *** SWAP W AND ROW I OF RMAT *** DO 10 J = I, P T = RMAT(IJ) RMAT(IJ) = W(J) W(J) = T IJ = IJ+J 10 CONTINUE T = QTR(I) QTR(I) = Y Y = T GO TO 60 20 IP1 = I+1 IJ = II+I IF ( ABS(WI) .LE. ABS(RI)) GO TO 40 RW = RI/WI T = SQRT(ONE+RW**2) IF (RW .GT. ZERO) T = -T V = RW-T U1 = ONE/T U2 = ONE/(T*V) RMAT(II) = WI*T T = Y+V*QTR(I) QTR(I) = QTR(I)+T*U1 Y = Y+T*U2 IF (IP1 .GT. P) GO TO 60 DO 30 J = IP1, P T = W(J)+V*RMAT(IJ) RMAT(IJ) = RMAT(IJ)+T*U1 W(J) = W(J)+T*U2 IJ = IJ+J 30 CONTINUE GO TO 60 C C *** AT THIS POINT WE MUST HAVE ABS(WI) .LE. ABS(RI)... C 40 WR = WI/RI T = - SQRT(ONE+WR**2) V = WR/(ONE-T) U1 = ONE/T-ONE U2 = V*U1 RMAT(II) = RI*T T = QTR(I)+V*Y QTR(I) = QTR(I)+T*U1 Y = Y+T*U2 IF (IP1 .GT. P) GO TO 60 DO 50 J = IP1, P T = RMAT(IJ)+V*W(J) RMAT(IJ) = RMAT(IJ)+T*U1 W(J) = W(J)+T*U2 IJ = IJ+J 50 CONTINUE 60 CONTINUE 999 RETURN 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 = ABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * ( ABS(X(I)) + ABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE DRLDST = ZERO IF (XMAX .GT. ZERO) DRLDST = EMAX / XMAX 999 RETURN C *** LAST LINE OF DRLDST FOLLOWS *** END SUBROUTINE DS7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, 1 Y) C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P), 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, J, K DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** DOUBLE PRECISION HALF, ONE, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C DOUBLE PRECISION DD7TPR, DV2NRM EXTERNAL DD7TPR, DS7LVM, DV2NRM C 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 = MIN(ONE, ABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL DS7LVM(P, U, A, STEP) T = HALF * (SIZE * DD7TPR(P, STEP, U) - DD7TPR(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST LINE OF DS7LUP FOLLOWS *** END SUBROUTINE DS7LVM(P, Y, S, X) C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, J, K DOUBLE PRECISION XI C C 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 LINE OF DS7LVM FOLLOWS *** END SUBROUTINE DV2AXY(P, W, A, X, Y) C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C INTEGER P DOUBLE PRECISION A, W(P), X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END DOUBLE PRECISION FUNCTION DV2NRM(P, X) C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C INTEGER P DOUBLE PRECISION X(P) C INTEGER I, J DOUBLE PRECISION ONE, R, SCALE, SQTETA, T, XI, ZERO DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C PARAMETER (ONE=1.D+0, ZERO=0.D+0) SAVE SQTETA DATA SQTETA/0.D+0/ C IF (P .GT. 0) GO TO 10 DV2NRM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE DV2NRM = ZERO GO TO 999 C 30 SCALE = ABS(X(I)) IF (I .LT. P) GO TO 40 DV2NRM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = DR7MDC(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = ABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C DV2NRM = SCALE * SQRT(T) 999 RETURN C *** LAST LINE OF DV2NRM FOLLOWS *** END SUBROUTINE DV7CPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C INTEGER P DOUBLE PRECISION X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) RETURN END SUBROUTINE DV7DFL(ALG, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER ALG, LV DOUBLE PRECISION V(LV) C DOUBLE PRECISION DR7MDC EXTERNAL DR7MDC C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS C DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR V *** C INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC, 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ, HUBERC, 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX, 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2, 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL C 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, HUBERC=48, 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21, 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49, 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28, 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34) C C------------------------------- BODY -------------------------------- C MACHEP = DR7MDC(3) V(AFCTOL) = 1.D-20 IF (MACHEP .GT. 1.D-10) V(AFCTOL) = MACHEP**2 V(DECFAC) = 0.5D+0 SQTEPS = DR7MDC(4) V(DFAC) = 0.6D+0 V(DTINIT) = 1.D-6 MEPCRT = MACHEP ** (ONE/THREE) V(D0INIT) = 1.D+0 V(EPSLON) = 0.1D+0 V(INCFAC) = 2.D+0 V(LMAX0) = 1.D+0 V(LMAXS) = 1.D+0 V(PHMNFC) = -0.1D+0 V(PHMXFC) = 0.1D+0 V(RDFCMN) = 0.1D+0 V(RDFCMX) = 4.D+0 V(RFCTOL) = MAX(1.D-10, MEPCRT**2) V(SCTOL) = V(RFCTOL) V(TUNER1) = 0.1D+0 V(TUNER2) = 1.D-4 V(TUNER3) = 0.75D+0 V(TUNER4) = 0.5D+0 V(TUNER5) = 0.75D+0 V(XCTOL) = SQTEPS V(XFTOL) = 1.D+2 * MACHEP C IF (ALG .GE. 2) GO TO 10 C C *** REGRESSION VALUES C V(COSMIN) = MAX(1.D-6, 1.D+2 * MACHEP) V(DINIT) = 0.D+0 V(DELTA0) = SQTEPS V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(FUZZ) = 1.5D+0 V(HUBERC) = 0.7D+0 V(RLIMIT) = DR7MDC(5) V(RSPTOL) = 1.D-3 V(SIGMIN) = 1.D-4 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 V(BIAS) = 0.8D+0 V(DINIT) = -1.0D+0 V(ETA0) = 1.0D+3 * MACHEP C 999 RETURN C *** LAST LINE OF DV7DFL FOLLOWS *** END SUBROUTINE DV7SCL(N, X, A, Y) C C *** SET X(I) = A*Y(I), I = 1(1)N *** C INTEGER N DOUBLE PRECISION A, X(N), Y(N) C INTEGER I C DO 10 I = 1, N 10 X(I) = A * Y(I) 999 RETURN C *** LAST LINE OF DV7SCL FOLLOWS *** END SUBROUTINE DV7SCP(P, Y, S) C C *** SET P-VECTOR Y TO SCALAR S *** C INTEGER P DOUBLE PRECISION S, Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = S RETURN END DOUBLE PRECISION FUNCTION DVSUM(N, X) INTEGER N DOUBLE PRECISION X(N) INTEGER I C DVSUM = 0.D+0 DO 10 I = 1, N 10 DVSUM = DVSUM + X(I) END LOGICAL FUNCTION STOPX(IDUMMY) C *****PARAMETERS... INTEGER IDUMMY C C .................................................................. C C *****PURPOSE... C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A C DYNAMIC STOPX. C C *****ALGORITHM NOTES... C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. C C .................................................................. C STOPX = .FALSE. RETURN END //GO.SYSIN DD dgletc.f cat >madsen.f <<'//GO.SYSIN DD madsen.f' C *** SIMPLE TEST PROGRAM FOR DGLG AND DGLF *** C INTEGER IV(92), LIV, LV, NOUT, UI(1) DOUBLE PRECISION V(200), X(2), UR(1) EXTERNAL I7MDCN, MADRJ, RHOLS INTEGER I7MDCN C C I7MDCN... RETURNS OUTPUT UNIT NUMBER. C INTEGER COVPRT, COVREQ, LASTIV, LASTV, LMAX0, RDREQ PARAMETER (COVPRT=14, COVREQ=15, LASTIV=44, LASTV=45, LMAX0=35, 1 RDREQ=57) C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NOUT = I7MDCN(1) LV = 200 LIV = 92 C C *** SPECIFY INITIAL X *** C X(1) = 3.D+0 X(2) = 1.D+0 C C *** SET IV(1) TO 0 TO FORCE ALL DEFAULT INPUT COMPONENTS TO BE USED. C IV(1) = 0 C WRITE(NOUT,10) 10 FORMAT(' DGLG ON PROBLEM MADSEN...') C C *** CALL DGLG, PASSING UI FOR RHOI, UR FOR RHOR, AND MADRJ FOR C *** UFPARM (ALL UNUSED IN THIS EXAMPLE). C CALL DGLG(3, 2, 2, X, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, UI, 1 UR, MADRJ) C C *** SEE HOW MUCH STORAGE DGLG USED... C WRITE(NOUT,20) IV(LASTIV), IV(LASTV) 20 FORMAT(' DGLG NEEDED LIV .GE. ,I3,12H AND LV .GE.',I4) C C *** SOLVE THE SAME PROBLEM USING DGLF... C WRITE(NOUT,30) 30 FORMAT(/' DGLF ON PROBLEM MADSEN...') X(1) = 3.D+0 X(2) = 1.D+0 IV(1) = 0 CALL DGLF(3, 2, 2, X, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, UI, 1 UR, MADRJ) C C *** REPEAT THE LAST RUN, BUT WITH A DIFFERENT INITIAL STEP BOUND C *** AND WITH THE COVARIANCE AND REGRESSION DIAGNOSTIC CALCUATIONS C *** SUPPRESSED... C C *** FIRST CALL DIVSET TO GET DEFAULT IV AND V INPUT VALUES... C CALL DIVSET(1, IV, LIV, LV, V) C C *** NOW ASSIGN THE NONDEFAULT VALUES. C IV(COVPRT) = 0 IV(COVREQ) = 0 IV(RDREQ) = 0 V(LMAX0) = 0.1D+0 X(1) = 3.D+0 X(2) = 1.D+0 C WRITE(NOUT,40) 40 FORMAT(/' DGLF ON PROBLEM MADSEN AGAIN...') C CALL DGLF(3, 2, 2, X, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, UI, 1 UR, MADRJ) C STOP END C*********************************************************************** C C MADRJ C C*********************************************************************** SUBROUTINE MADRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) INTEGER N, P, NF, NEED, UI(1) DOUBLE PRECISION X(P), R(N), RP(P,N), UR(1) EXTERNAL UF DOUBLE PRECISION TWO, ZERO PARAMETER (TWO = 2.D+0, ZERO = 0.D+0) C C *** BODY *** C IF (NEED .EQ. 2) GO TO 10 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) GO TO 999 C 10 RP(1,1) = TWO*X(1) + X(2) RP(2,1) = TWO*X(2) + X(1) RP(1,2) = COS(X(1)) RP(2,2) = ZERO RP(1,3) = ZERO RP(2,3) = -SIN(X(2)) C 999 RETURN END SUBROUTINE RHOLS(NEED, F, N, NF, XN, R, RP, UI, UR, W) C C *** LEAST-SQUARES RHO *** C INTEGER NEED(2), N, NF, UI(1) DOUBLE PRECISION F, XN(*), R(N), RP(N), UR(1), W(N) C C *** EXTERNAL FUNCTIONS *** C EXTERNAL DR7MDC, DV2NRM DOUBLE PRECISION DR7MDC, DV2NRM C C *** LOCAL VARIABLES *** C INTEGER I DOUBLE PRECISION HALF, ONE, RLIMIT, ZERO DATA HALF/0.5D+0/, ONE/1.D+0/, RLIMIT/0.D+0/, ZERO/0.D+0/ C C *** BODY *** C IF (NEED(1) .EQ. 2) GO TO 20 IF (RLIMIT .LE. ZERO) RLIMIT = DR7MDC(5) C ** SET F TO 2-NORM OF R ** F = DV2NRM(N, R) IF (F .GE. RLIMIT) GO TO 10 F = HALF * F**2 GO TO 999 C C ** COME HERE IF F WOULD OVERFLOW... 10 NF = 0 GO TO 999 C 20 DO 30 I = 1, N RP(I) = ONE W(I) = ONE 30 CONTINUE 999 RETURN C *** LAST LINE OF RHOLS FOLLOWS *** END //GO.SYSIN DD madsen.f cat >madsenb.f <<'//GO.SYSIN DD madsenb.f' C *** SIMPLE TEST PROGRAM FOR DGLGB AND DGLFB *** C INTEGER IV(92), LIV, LV, NOUT, UI(1) DOUBLE PRECISION B(2,2), V(200), X(2), UR(1) EXTERNAL I7MDCN, MADRJ, RHOLS INTEGER I7MDCN C C I7MDCN... RETURNS OUTPUT UNIT NUMBER. C INTEGER LASTIV, LASTV, LMAX0 PARAMETER (LASTIV=44, LASTV=45, LMAX0=35) C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NOUT = I7MDCN(1) LV = 200 LIV = 92 C C *** SPECIFY INITIAL X AND BOUNDS ON X *** C X(1) = 3.D+0 X(2) = 1.D+0 C *** BOUNDS ON X(1)... B(1,1) = -.1D+0 B(2,1) = 10.D+0 C *** BOUNDS ON X(2)... B(1,2) = 0.D+0 B(2,2) = 2.D+0 C C *** SET IV(1) TO 0 TO FORCE ALL DEFAULT INPUT COMPONENTS TO BE USED. C IV(1) = 0 C WRITE(NOUT,10) 10 FORMAT(' DGLGB ON PROBLEM MADSEN...') C C *** CALL DGLG, PASSING UI FOR RHOI, UR FOR RHOR, AND MADRJ FOR C *** UFPARM (ALL UNUSED IN THIS EXAMPLE). C CALL DGLGB(3, 2, 2, X, B, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, 1 UI,UR, MADRJ) C C *** SEE HOW MUCH STORAGE DGLGB USED... C WRITE(NOUT,20) IV(LASTIV), IV(LASTV) 20 FORMAT(' DGLGB NEEDED LIV .GE. ,I3,12H AND LV .GE.',I4) C C *** SOLVE THE SAME PROBLEM USING DGLFB... C WRITE(NOUT,30) 30 FORMAT(/' DGLFB ON PROBLEM MADSEN...') X(1) = 3.D+0 X(2) = 1.D+0 IV(1) = 0 CALL DGLFB(3, 2, 2, X, B, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, 1 UI,UR, MADRJ) C C *** REPEAT THE LAST RUN, BUT WITH A DIFFERENT INITIAL STEP BOUND C C *** FIRST CALL DIVSET TO GET DEFAULT IV AND V INPUT VALUES... C CALL DIVSET(1, IV, LIV, LV, V) C C *** NOW ASSIGN THE NONDEFAULT VALUES. C V(LMAX0) = 0.1D+0 X(1) = 3.D+0 X(2) = 1.D+0 C WRITE(NOUT,40) 40 FORMAT(/' DGLFB ON PROBLEM MADSEN AGAIN...') C CALL DGLFB(3, 2, 2, X, B, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, 1 UI,UR, MADRJ) C STOP END C*********************************************************************** C C MADRJ C C*********************************************************************** SUBROUTINE MADRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) INTEGER N, P, NF, NEED, UI(1) DOUBLE PRECISION X(P), R(N), RP(P,N), UR(1) EXTERNAL UF DOUBLE PRECISION TWO, ZERO PARAMETER (TWO=2.D+0, ZERO=0.D+0) C C *** BODY *** C IF (NEED .EQ. 2) GO TO 10 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) GO TO 999 C 10 RP(1,1) = TWO*X(1) + X(2) RP(2,1) = TWO*X(2) + X(1) RP(1,2) = COS(X(1)) RP(2,2) = ZERO RP(1,3) = ZERO RP(2,3) = -SIN(X(2)) C 999 RETURN END SUBROUTINE RHOLS(NEED, F, N, NF, XN, R, RP, UI, UR, W) C C *** LEAST-SQUARES RHO *** C INTEGER NEED(2), N, NF, UI(1) DOUBLE PRECISION F, XN(*), R(N), RP(N), UR(1), W(N) C C *** EXTERNAL FUNCTIONS *** C EXTERNAL DR7MDC, DV2NRM DOUBLE PRECISION DR7MDC, DV2NRM C C *** LOCAL VARIABLES *** C INTEGER I DOUBLE PRECISION HALF, ONE, RLIMIT, ZERO DATA HALF/0.5D+0/, ONE/1.D+0/, RLIMIT/0.D+0/, ZERO/0.D+0/ C C *** BODY *** C IF (NEED(1) .EQ. 2) GO TO 20 IF (RLIMIT .LE. ZERO) RLIMIT = DR7MDC(5) C ** SET F TO 2-NORM OF R ** F = DV2NRM(N, R) IF (F .GE. RLIMIT) GO TO 10 F = HALF * F**2 GO TO 999 C C ** COME HERE IF F WOULD OVERFLOW... 10 NF = 0 GO TO 999 C 20 DO 30 I = 1, N RP(I) = ONE W(I) = ONE 30 CONTINUE 999 RETURN C *** LAST LINE OF RHOLS FOLLOWS *** END //GO.SYSIN DD madsenb.f cat >dpmain.f <<'//GO.SYSIN DD dpmain.f' PROGRAM PMAIN C *** MAIN PROGRAM FOR RUNNING PREG EXAMPLES USING DGLG *** INTEGER LIV, LV, MMAX, NMAX, NW, NR0, PMAX PARAMETER (LIV=200, LV=8000, NW=6, MMAX = 18, NMAX=200, NR0=8, 1 PMAX=20) CHARACTER*72 FNAME CHARACTER*6 ALGNAM(4) INTEGER ALG, I, IV(LIV), J, J0, J1, K, KDIAG, M, MDL(6), MODEL, 1 N, NIN, NR, NRUN, P, P0, PS, RHOI(NMAX+6), UI(7) DOUBLE PRECISION A((MMAX+6)*NMAX), B(2,PMAX), 1 RHOR((17+PMAX)*NMAX+4), T, T1, V(LV), X(PMAX+3), 1 X0(PMAX+3), YN(2,7*NMAX+3) EQUIVALENCE (RHOI(1), MDL(1)), (RHOR(1), YN(1,1)) CHARACTER*96 DESC, FMT CHARACTER*8 WNAME(4) DOUBLE PRECISION DR7MDC EXTERNAL BRJ, CHKDER, DEVIAN, DGLF, DGLFB, DGLG, DGLGB, DIVSET, 1 DR7MDC, DV7CPY, DV7SCP, LOUCHK, POIX0, RHPOIL, RPOIL0 DOUBLE PRECISION ONE INTEGER BS, BSSTR, F, FLO, FLOSTR, LOO, NB, NFIX, RDREQ, XNOTI PARAMETER (BS=85, BSSTR=86, F=10, FLO=88, FLOSTR=89, LOO=84, 1 NB=87, NFIX=83, RDREQ=57, XNOTI=90) DATA ALG/1/, KDIAG/0/, NIN/5/ DATA ALGNAM(1)/'DGLG'/, ALGNAM(2)/'DGLF'/ DATA ALGNAM(3)/'DGLGB'/, ALGNAM(4)/'DGLFB'/ DATA ONE/1.D+0/ DATA WNAME(1)/' RHO" '/, WNAME(2)/' IRLS '/, 1 WNAME(3)/' SCORE '/, WNAME(4)/'DEVIANCE'/ C C *** BODY *** C CALL DIVSET(1, IV, LIV, LV, V) IV(FLO) = 16*NMAX + 5 IV(XNOTI) = IV(FLO) + NMAX IV(BS) = 7 IV(BSSTR) = 1 IV(FLOSTR) = 1 IV(LOO) = 1 IV(NB) = 5 IV(NFIX) = 0 CALL DV7SCP(NMAX, RHOR(IV(FLO)), ONE) CALL DV7SCP(NMAX, RHOR(IV(XNOTI)), -2.D+0) DO 10 I = IV(BS), IV(BS) + NMAX - 1 10 RHOI(I) = 1 T = DR7MDC(6) DO 20 I = 1, PMAX B(1,I) = -T B(2,I) = T 20 CONTINUE NRUN = 0 MDL(6) = 1 30 READ(NIN,*,END=210) K WRITE(NW,*) '*', K GO TO (40, 50, 60, 70, 80, 90, 100, 110, 170, 180, 220, 1 230, 240, 250, 260, 270, 300, 310, 320, 340, 2 350, 360, 370, 380, 390, 430, 440, 450), K WRITE(NW,*) '/// Invalid command', K 40 WRITE(NW,*) '1 = LIST MENU' WRITE(NW,*) '2 = READ IV' WRITE(NW,*) '3 = READ V' WRITE(NW,*) 1 '4 = READ ALG: 1 = DGLG, 2 = DGLF, 3 = DGLGB, 4 = DGLFB' WRITE(NW,*) '5 = READ ALL OF X0' WRITE(NW,*) '6 = COPY X TO X0' WRITE(NW,*) '7 = START' WRITE(NW,*) '8 = CONTINUE' WRITE(NW,*) '9 = READ COMMANDS FROM SPECIFIED FILE' WRITE(NW,*) '10 = READ PROBLEM' WRITE(NW,*) '11 = READ RHO' WRITE(NW,*) '12 = READ MODEL' WRITE(NW,*) '13 = CHECK RHO DERIVATIVES' WRITE(NW,*) '14 = READ P' WRITE(NW,*) '15 = READ X0 COMPONENTWISE' WRITE(NW,*) '16 = read new Y' WRITE(NW,*) 1 '17 = negate RHO (negative ==> use weights; see KW = 19)' WRITE(NW,*) '18 = read KDIAG: 1 = from X*, 2 = from X0, 3 = both' WRITE(NW,*) 1 '19 = read KW: 1 = RHO", 2 = IRLS, 3 = score, 4 = deviance' WRITE(NW,*) '20 = READ B (format i, b(1,i), b(2,i))' WRITE(NW,*) '21,22 = Read,Show RHOI (componentwise)' WRITE(NW,*) '23,24 = Read,Show RHOR "' WRITE(NW,*) '25 = Show range of RHOR components' WRITE(NW,*) '26,27 = Show IV, V components' WRITE(NW,*) '28 = Read and echo comment' GO TO 30 50 READ(NIN,*,END=210) I, J IF (I .LE. 0) GO TO 30 IV(I) = J GO TO 50 60 READ(NIN,*,END=210) I, T IF (I .LE. 0) GO TO 30 V(I) = T GO TO 60 70 READ(NIN,*,END=210) ALG GO TO 30 80 READ(NIN,*,END=210) (X0(I), I = 1, P0) GO TO 30 90 CALL DV7CPY(P0+3, X0, X) GO TO 30 100 CALL DV7CPY(P0+3, X, X0) IV(1) = 12 110 UI(6) = M NRUN = NRUN + 1 IF (IV(1) .EQ. 0 .OR. IV(1) .EQ. 12) THEN WRITE(NW,'(/'' Run'',I5,'': calling '',A,'' with PS ='',I5)') 1 NRUN, ALGNAM(ALG), PS ELSE WRITE(NW,'(/'' Run'',I5,'': continuing '',A,'', PS ='',I5)') 1 NRUN, ALGNAM(ALG), PS END IF IF (KDIAG .GT. 0) IV(RDREQ) = 2 GO TO (120,130,140,150), ALG 120 CALL DGLG(N, P, PS, X, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 160 130 CALL DGLF(N, P, PS, X, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 160 140 CALL DGLGB(N, P, PS, X, B, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 30 150 CALL DGLFB(N, P, PS, X, B, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 30 160 IF (IV(1) .LT. 8) THEN CALL DEVIAN(V(F), MDL(1), N, NW, X(PS+1), YN) IF (ALG .EQ. 1) CALL LOUCHK(KDIAG, DGLG, X0, N, P, PS, X, 1 RHPOIL, MDL, YN, IV, LIV, LV, V, BRJ, UI, A, BRJ) IF (ALG .EQ. 2) CALL LOUCHK(KDIAG, DGLF, X0, N, P, PS, X, 1 RHPOIL, MDL, YN, IV, LIV, LV, V, BRJ, UI, A, BRJ) END IF GO TO 30 170 IF (NIN .LE. 1) THEN WRITE(NW,*) '*** TOO MANY FILES OPEN' GO TO 30 END IF READ(NIN,'(A)',END=200) FNAME NIN = NIN - 1 OPEN(NIN,FILE=FNAME,STATUS='OLD',ERR=410) REWIND NIN GO TO 30 180 READ(NIN,'(A)',END=200) FNAME IF (FNAME .EQ. '-') THEN NR = NIN ELSE OPEN(NR0,FILE=FNAME,STATUS='OLD',ERR=410) REWIND NR0 NR = NR0 END IF READ(NR, '(A)', END=200) DESC WRITE(NW,*) DESC READ(NR, '(9I4)', END=200) N, P, MODEL, M, MDL(1), I, J, PS P0 = P IF (PS .EQ. 0) PS = P IF (MODEL .LE. 2) M = PS IF (MIN(MDL(1),M,N,PS,P-PS+1,MODEL+1) .LE. 0 .OR. P .GT. PMAX 1 .OR. M .GT. MMAX) THEN WRITE(NW,*) 'INVALID PROBLEM DIMENSIONS: M, N, P, MODEL =', 1 M, N, P, MODEL STOP END IF MDL(2) = P MDL(3) = PS UI(1) = M UI(2) = MODEL UI(3) = 2 UI(4) = 0 UI(5) = 0 UI(7) = PS CALL DV7SCP(3, X0(P+1), ONE) IF (MODEL .GT. 2) THEN READ(NR, *, END=200) (X0(I), I = 1, P) ELSE IF (PS .LT. P) THEN READ(NR, *, END=200) (X0(I), I = PS+1, P) END IF READ(NR, '(A)', END=200) FMT J1 = 0 DO 190 I = 1, N J0 = J1 + 1 J1 = J1 + M READ(NR, FMT, END=200) YN(1,I), YN(2,I), (A(J), J = J0, J1) C FROME*S DOCUMENTATION CLAIMS Y(I) IS YBAR(I), BUT HIS PROGRAM C ASSUMES IT IS THE TOTAL COUNT AND TURNS Y(I) INTO YBAR(I) C BY THE EQUIVALENT OF THE FOLLOWING STATEMENT... C YN(1,I) = YN(1,I) / YN(2,I) 190 CONTINUE IF (MODEL .LE. 2) THEN CALL POIX0(A, IV, PS, LIV, LV, MODEL, N, PS, V, X0, YN) END IF GO TO 30 200 WRITE(NW,*) '*** PREMATURE END OF FILE' IF (NR .NE. NIN) GO TO 30 210 IF (NIN .GE. 5) STOP NIN = NIN + 1 GO TO 30 220 READ(NIN,*,END=210) I IF (I .LE. 0) I = MDL(1) WRITE(NW,*) 'Changing RHO from ', MDL(1), ' to ', I MDL(1) = I GO TO 30 230 READ(NIN,*,END=210) I IF (I .EQ. 0) I = MODEL WRITE(NW,*) 'Changing MODEL from ', MODEL, ' to ', I MODEL = I UI(2) = MODEL GO TO 30 240 CALL CHKDER(MDL, N, P-PS, X0(PS+1), V(200), RHPOIL, RPOIL0, YN) GO TO 30 250 READ(NIN,*,END=210) I IF (I .GT. P0 .OR. I .LT. P0-3) THEN WRITE(NW,*) 'INVALID P = ', I, ' -- P REMAINS ', P ELSE P = I MDL(2) = I END IF GO TO 30 260 READ(NIN,*,END=210) I, T IF (I .LE. 0) GO TO 30 X0(I) = T GO TO 260 270 DO 280 I = 1, N 280 READ(NIN, FMT, END=290) YN(1,I), YN(2,I) GO TO 30 290 WRITE(NW,*) 'Premature end of file!' GO TO 210 300 I = 1 IF (MDL(6) .EQ. 1) I = 2 GO TO 330 310 READ(NIN,*,END=210) KDIAG GO TO 30 320 READ(NIN,*,END=210) I I = MIN(4, MAX0(I,1)) 330 WRITE(NW,*) 'KW changed from ', MDL(6), ' = ', WNAME(MDL(6)), 1 ' to ', I, ' = ', WNAME(I) MDL(6) = I GO TO 30 340 READ(NIN,*,END=210) I, T, T1 IF (I .LE. 0) GO TO 30 B(1,I) = T B(2,I) = T1 GO TO 340 350 READ(NIN,*,END=210) I, J IF (I .LE. 0) GO TO 30 RHOI(I) = J GO TO 350 360 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'RHOI(',I,') = ', RHOI(I) GO TO 360 370 READ(NIN,*,END=210) I, T IF (I .LE. 0) GO TO 30 RHOR(I) = T GO TO 370 380 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'RHOR(',I,') = ', RHOR(I) GO TO 380 390 READ(NIN,*,END=210) I, J IF (I .LE. 0) GO TO 30 WRITE(*,*) (RHOR(K), K = I, J) GO TO 390 410 WRITE(*,420) FNAME 420 FORMAT(' Can''t open ',A) GO TO 30 430 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'IV(',I,') = ', IV(I) GO TO 430 440 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'V(',I,') = ', V(I) GO TO 440 450 READ(NIN,'(A)',END=200) FNAME WRITE(NW,*) FNAME GO TO 30 END SUBROUTINE BRJ(N, P, X, NF, NEED, R, RP, UI, A, UF) INTEGER N, P, NF, NEED(2), UI(5) DOUBLE PRECISION X(P), R(N), RP(P,N), A(*) EXTERNAL UF EXTERNAL BRJ1 INTEGER M C C *** BODY *** C M = UI(6) CALL BRJ1(M, N, UI(7), X, NF, NEED, R, RP, UI, A, A(M*N+1), UF) 999 RETURN END SUBROUTINE BRJ1(M, N, P, X, NF, NEED, R, RP, UI, A, UR, UF) INTEGER M, N, P, NF, NEED(2), UI(5) DOUBLE PRECISION X(P), R(N), RP(P,N), A(M,N), UR(N,6) EXTERNAL UF EXTERNAL DD7TPR, DR7MDC DOUBLE PRECISION DD7TPR, DR7MDC C C *** LOCAL VARIABLES *** C INTEGER I, J, J2, J4, MODEL DOUBLE PRECISION ALPHA, BETA1, BETA2, DI, E, EMX, PHI, T, T1, 1 THETA, TI, X1, X1INV, X2, X3, X3M1, X4 DOUBLE PRECISION EXPMAX, EXPMIN, ONE, TWO, ZERO DATA EXPMAX/0.D+0/, EXPMIN/0.D+0/, ONE/1.D+0/, TWO/2.D+0/, 1 ZERO/0.D+0/ C C *** BODY *** C MODEL = IABS(UI(2)) IF (MODEL .LE. 0) GO TO 520 IF (MODEL .GT. 11) GO TO 520 IF (EXPMAX .GT. ZERO) GO TO 10 EXPMAX = TWO * DLOG(DR7MDC(5)) EXPMIN = TWO * DLOG(DR7MDC(2)) 10 IF (NEED(1) .EQ. 2) GO TO 260 J = 3 - UI(3) IF (UI(3+J) .EQ. NEED(2)) J = UI(3) UI(3) = J UI(3+J) = NF J2 = J + 2 J4 = J + 4 GO TO (20, 40, 60, 60, 80, 100, 120, 170, 190, 210, 230), MODEL C C *** LINEAR MODEL *** C 20 DO 30 I = 1, N 30 R(I) = DD7TPR(P, X, A(1,I)) GO TO 999 C C *** EXPONENTIAL OF LINEAR *** C 40 DO 50 I = 1, N T = DD7TPR(P, X, A(1,I)) IF (T .GE. EXPMAX) GO TO 520 E = ZERO IF (T .GT. EXPMIN) E = DEXP(T) R(I) = E UR(I,J) = E 50 CONTINUE GO TO 999 C C *** NONLINEAR POISSON EXAMPLE FROM FROME*S PREG MANUAL *** C 60 X1 = X(1) X2 = X(2) X3 = X(3) DO 70 I = 1, N E = DEXP(-X2*A(2,I)) UR(I,J2) = E T = (ONE - E) ** X3 UR(I,J4) = T T = X1*A(1,I) * (ONE - T) IF (T .LE. ZERO) GO TO 520 UR(I,J) = T IF (MODEL .EQ. 3) T = DLOG(T) R(I) = T 70 CONTINUE GO TO 999 C C *** CAESIUM DOSE EFFECT MODEL *** C 80 X1 = X(1) X2 = X(2) X3 = X(3) DO 90 I = 1, N DI = A(1,I) TI = A(2,I) IF (X3 .EQ. ZERO) GO TO 520 IF (TI .EQ. ZERO) GO TO 520 T = -TI / X3 IF (T .GE. EXPMAX) GO TO 520 E = ZERO IF (T .GT. EXPMIN) E = DEXP(T) UR(I,J) = E T = X3 / TI T = DI * (X2 + TWO*T*DI*(ONE - T*(ONE - E))) UR(I,J2) = T R(I) = X1 * T 90 CONTINUE GO TO 999 C C *** LUNG CANCER MODEL *** C 100 X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) EMX = EXPMAX - 10.D+0 DO 110 I = 1, N T1 = X1 * A(1,I) T = X2 + X3*A(2,I) + T1 IF (T .GE. EMX) GO TO 520 E = ZERO IF (T .GT. EXPMIN) E = DEXP(T) T = X4 + T1 IF (T .GE. EMX) GO TO 520 T1 = ZERO IF (T .GT. EXPMIN) T1 = DEXP(T) T = E + T1 R(I) = T UR(I,J) = E UR(I,J2) = T1 UR(I,J4) = T 110 CONTINUE GO TO 999 C C *** LOGISTIC OF LINEAR *** C 120 DO 160 I = 1, N T = DD7TPR(P, A(1,I), X) IF (T .LE. EXPMIN) GO TO 130 IF (T .GE. EXPMAX) GO TO 140 E = DEXP(T) T1 = ONE / (ONE + E) T = E * T1 T1 = T * T1 GO TO 150 130 T = ZERO T1 = ZERO GO TO 150 140 T = ONE T1 = ZERO 150 R(I) = T UR(I,J) = T1 160 CONTINUE GO TO 999 C C *** LOG OF LINEAR *** C 170 DO 180 I = 1, N T = DD7TPR(P, X, A(1,I)) IF (T .LE. ZERO) GO TO 520 R(I) = DLOG(T) UR(I,J) = T 180 CONTINUE GO TO 999 C C *** EXAMPLE ON P. 204 OF MCCULLAGH AND NELDER *** C 190 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) DO 200 I = 1, N X2 = A(2,I) R(I) = ALPHA + BETA1*DLOG(A(1,I)) + BETA2*X2/(PHI + X2) 200 CONTINUE GO TO 999 C C *** EXAMPLE ON P. 205 OF MCCULLAGH AND NELDER *** C 210 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) THETA = X(5) DO 220 I = 1, N X2 = A(2,I) T = A(1,I) - THETA IF (T .LE. ZERO) GO TO 520 R(I) = ALPHA + BETA1*DLOG(T) + BETA2*X2/(PHI + X2) 220 CONTINUE GO TO 999 C C *** EXAMPLE P. 202 OF MCCULLAGH AND NELDER *** C 230 DO 250 I = 1, N T = X(1) DO 240 J = 1, 3 T1 = A(J,I) + X(2*J+1) IF (T1 .LE. ZERO) GO TO 520 240 T = T + X(2*J)/T1 R(I) = T 250 CONTINUE GO TO 999 C C *** JACOBIAN EVALUATIONS... C 260 J = UI(3) IF (NF .EQ. UI(J+3)) GO TO 270 J = 3 - J IF (NF .EQ. UI(J+3)) GO TO 270 WRITE(6,*) 'HELP! UNAVAILABLE INTERMEDIATE INFO!' GO TO 520 270 J2 = J + 2 J4 = J + 4 GO TO (280, 290, 310, 340, 370, 390, 410, 430, 450, 470, 490), 1 MODEL C C *** LINEAR MODEL *** C C 280 CALL DV7CPY(N*P, RP, A) GO TO 999 C C *** EXPONENTIAL OF LINEAR MODEL *** C 290 DO 300 I = 1, N 300 CALL DV7SCL(P, RP(1,I), UR(I,J), A(1,I)) GO TO 999 C C *** LOG OF NONLINEAR POISSON EXAMPLE FROM FROME*S PREG MANUAL *** C 310 X1 = X(1) X2 = X(2) X3 = X(3) X3M1 = X3 - ONE X1INV = ONE / X1 DO 330 I = 1, N RP(1,I) = X1INV E = UR(I,J2) T1 = ONE - E T = -A(1,I) * X1 / UR(I,J) RP(2,I) = T * X3 * A(2,I) * E * T1**X3M1 IF (T1 .LE. ZERO) GO TO 320 RP(3,I) = T * UR(I,J4) * DLOG(T1) GO TO 330 320 RP(3,I) = ZERO 330 CONTINUE GO TO 999 C C *** NONLINEAR POISSON EXAMPLE FROM FROME*S PREG MANUAL *** C 340 X1 = X(1) X2 = X(2) X3 = X(3) X3M1 = X3 - ONE X1INV = ONE / X1 DO 360 I = 1, N RP(1,I) = A(1,I) * (ONE - UR(I,J4)) E = UR(I,J2) T1 = ONE - E T = -A(1,I) * X1 RP(2,I) = T * X3 * A(2,I) * E * T1**X3M1 IF (T1 .LE. ZERO) GO TO 350 RP(3,I) = T * UR(I,J4) * DLOG(T1) GO TO 360 350 RP(3,I) = ZERO 360 CONTINUE GO TO 999 C C *** CAESIUM DOSE EFFECT MODEL *** C 370 X1 = X(1) X3 = X(3) DO 380 I = 1, N RP(1,I) = UR(I,J2) DI = A(1,I) TI = A(2,I) RP(2,I) = X1 * DI E = UR(I,J) T = TWO * X3 / TI RP(3,I) = TWO * X1 * (DI/TI) * DI * (ONE - T + E*(T + ONE)) 380 CONTINUE GO TO 999 C C *** LUNG CANCER MODEL *** C 390 DO 400 I = 1, N RP(1,I) = UR(I,J4) * A(1,I) T = UR(I,J) RP(2,I) = T RP(3,I) = T * A(2,I) RP(4,I) = UR(I,J2) 400 CONTINUE GO TO 999 C C *** LOGISTIC OF LINEAR *** C 410 DO 420 I = 1, N 420 CALL DV7SCL(P, RP(1,I), UR(I,J), A(1,I)) GO TO 999 C C *** LOG OF LINEAR *** C 430 DO 440 I = 1, N 440 CALL DV7SCL(P, RP(1,I), ONE/UR(I,J), A(1,I)) GO TO 999 C C *** EXAMPLE ON P. 204 OF MCCULLAGH AND NELDER *** C 450 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) DO 460 I = 1, N X2 = A(2,I) C R(1,I) = ALPHA + BETA1*DLOG(A(1,I)) + BETA2*X2/(PHI + X2) RP(1,I) = ONE RP(2,I) = DLOG(A(1,I)) RP(3,I) = X2/(PHI + X2) RP(4,I) = -BETA2*X2/(PHI + X2)**2 RP(1,I) = ONE 460 CONTINUE GO TO 999 C C C *** EXAMPLE ON P. 205 OF MCCULLAGH AND NELDER *** C 470 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) THETA = X(5) DO 480 I = 1, N X2 = A(2,I) C R(I) = ALPHA + BETA1*DLOG(A(1,I) - THETA) + BETA2*X2/(PHI + X2) RP(1,I) = ONE RP(2,I) = DLOG(A(1,I) - THETA) RP(3,I) = X2/(PHI + X2) RP(4,I) = -BETA2*X2/(PHI + X2)**2 RP(5,I) = -BETA1/(A(1,I) - THETA) 480 CONTINUE GO TO 999 C C *** EXAMPLE P. 202 OF MCCULLAGH AND NELDER *** C 490 DO 510 I = 1, N C DO 453 J = 1, 3 C453 RI = RI + X(2*J)/(A(J,I) + X(2*J+1)) RP(1,I) = ONE DO 500 J = 1, 3 T = ONE / (A(J,I) + X(2*J+1)) RP(2*J,I) = T RP(2*J+1,I) = -X(2*J)*T*T 500 CONTINUE 510 CONTINUE GO TO 999 520 NF = 0 999 RETURN END SUBROUTINE CHKDER(MDL, N, NPT, PT, R, RHO, RHO0, YN) INTEGER MDL(1), N, NPT C DOUBLE PRECISION PT(NPT) -- BUT NPT MAY BE 0 DOUBLE PRECISION PT(1), R(N,20), YN(2,N) EXTERNAL RHO, RHO0 EXTERNAL DV2NRM DOUBLE PRECISION DV2NRM INTEGER I, J DOUBLE PRECISION F, H, T REAL FOO(10), FAC DATA FOO/.1, -.1, .2, -.2, .4, -.4, .6, -.6, .8, -.9/, H/.001D0/ C C *** BODY *** C J = 1 FAC = 1.0 DO 10 I = 1, N T = FAC * FOO(J) R(I,1) = T R(I,10) = T + H J = J + 1 IF (J .LE. 10) GO TO 10 J = 1 FAC = 10. * FAC 10 CONTINUE CALL RHO0(MDL, N, PT, R, R(1,4), YN) CALL RHO0(MDL, N, PT, R(1,10), R(1,13), YN) DO 20 I = 1, N T = R(I,10) - R(I,1) IF (T .NE. 0.D0) T = 1.D0 / T R(I,20) = T 20 CONTINUE CALL DV2AXY(N, R(1,13), -1.D0, R(1,4), R(1,13)) CALL DV7VMP(N, R(1,13), R(1,13), R(1,20), 1) J = 1 CALL RHO(0, F, N, J, PT, R, R(1,4), MDL, YN) CALL RHO(1, F, N, J, PT, R, R(1,4), MDL, YN) CALL DV2AXY(N, R(1,19), -1.D0, R(1,13), R) T = DV2NRM(N,R(1,19))/(DV2NRM(N,R(1,13)) + DV2NRM(N,R)) WRITE(6,*) '1ST DERIV RELATIVE DIFFERENCE =', T IF (T .GT. .01) THEN WRITE(6,*) 'I FD(I) AN(I)' WRITE(6,'(I5,2G13.4)') (I, R(I,13), R(I,1), I = 1, N) END IF CALL RHO(0, F, N, J, PT, R(1,10), R(1,13), MDL, YN) CALL RHO(1, F, N, J, PT, R(1,10), R(1,13), MDL, YN) CALL DV2AXY(N, R(1,19), -1.D0, R, R(1,10)) CALL DV7VMP(N, R(1,19), R(1,19), R(1,20), 1) CALL DV2AXY(N, R(1,13), -1.D0, R(1,19), R(1,4)) T = DV2NRM(N,R(1,13))/(DV2NRM(N,R(1,4)) + DV2NRM(N,R(1,19))) WRITE(6,*) '2ND DERIV RELATIVE DIFFERENCE =', T IF (T .GT. .01) THEN WRITE(6,*) 'I FD(I) AN(I)' WRITE(6,'(I5,2G13.4)') (I, R(I,19), R(I,4), I = 1, N) END IF 999 RETURN END SUBROUTINE RPOIL0(MDL, N, PT, R, RHO, YN) INTEGER N, MDL(1) DOUBLE PRECISION PT(1), R(N), RHO(N), YN(2,N) EXTERNAL LPN, DR7MDC DOUBLE PRECISION LPN, DR7MDC INTEGER I, MODEL DOUBLE PRECISION E, RI, T, YI DOUBLE PRECISION DEXP, DLOG DOUBLE PRECISION EXPMAX, EXPMIN, HALF, ONE, TWO, ZERO DATA EXPMAX/0.D+0/, EXPMIN/0.D+0/, 1 HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/ C C *** BODY *** C MODEL = MDL(1) I = MODEL + 2 IF (I .LE. 0 .OR. I .GT. 11) THEN WRITE(6,*) 'HELP! RPOIL0 HAS MODEL =', MODEL STOP END IF IF (EXPMAX .GT. ZERO) GO TO 10 EXPMAX = TWO * DLOG(DR7MDC(5)) EXPMIN = TWO * DLOG(DR7MDC(2)) 10 GO TO (20, 20, 40, 60, 80, 80, 100, 120, 140, 160, 180), I C C *** POISSON RHO (AND CONVENTIONAL IRLS) *** C 20 DO 30 I = 1, N RI = R(I) IF (RI .LE. ZERO) THEN RI = ONE R(I) = ONE END IF RHO(I) = YN(2,I)*RI - YN(1,I)*DLOG(RI) 30 CONTINUE GO TO 999 C C *** LOG LINEAR *** C 40 DO 50 I = 1, N E = ZERO RI = R(I) IF (RI .GT. EXPMAX) THEN RI = HALF * EXPMAX R(I) = RI END IF IF (RI .GT. EXPMIN) E = EXP(RI) RHO(I) = YN(2,I)*E - YN(1,I)*RI 50 CONTINUE GO TO 999 C C *** SQUARE-ROOT LINEAR POISSON *** C 60 DO 70 I = 1, N RI = R(I) IF (RI .LE. ZERO) THEN RI = ONE R(I) = RI END IF RHO(I) = YN(2,I)*RI**2 - TWO*YN(1,1)*DLOG(RI) 70 CONTINUE GO TO 999 C C *** BINOMIAL RHO (AND CONVENTIONAL IRLS) *** C 80 DO 90 I = 1, N RI = R(I) IF (RI .LE. ZERO .OR. RI .GE. ONE) THEN RI = HALF R(I) = RI END IF RHO(I) = -YN(1,I)*DLOG(RI) - (YN(2,I) - YN(1,I))*DLOG(ONE-RI) 90 CONTINUE GO TO 999 C C *** BINOMIAL LOGISTIC RHO *** C 100 DO 110 I = 1, N RI = R(I) IF (RI .GT. EXPMAX) THEN RI = HALF * EXPMAX R(I) = RI END IF E = ZERO IF (RI .GT. EXPMIN) E = DEXP(RI) RHO(I) = YN(2,I)*DLOG(ONE + E) - YN(1,I)*RI 110 CONTINUE GO TO 999 C C *** PROBIT *** C 120 DO 130 I = 1, N RI = R(I) YI = YN(1,I) RHO(I) = -YI*LPN(RI) - (YN(2,I)-YI)*LPN(-RI) 130 CONTINUE GO TO 999 C C *** WEIBULL *** C 140 DO 150 I = 1, N RI = R(I) IF (RI .GT. EXPMAX) THEN RI = HALF * EXPMAX R(I) = RI END IF E = ZERO IF (RI .GT. EXPMIN) E = DEXP(RI) T = ZERO IF (-E .GT. EXPMIN) T = DEXP(-E) RHO(I) = (YN(2,I) - YN(1,I))*E - YN(1,I)*DLOG(ONE - T) 150 CONTINUE GO TO 999 C C *** GAMMA ERRORS *** C 160 DO 170 I = 1, N RI = R(I) IF (RI .LE. ZERO) THEN WRITE(6,*) 'HELP! CHKDER HAS R(',I,') =', RI,' < 0' STOP END IF RHO(I) = YN(2,I) * (YN(1,I)*RI - DLOG(RI)) 170 CONTINUE GO TO 999 C C *** PREGIBON ERRORS *** C C *** IN THIS CASE, YN(1,I) = Y(I), YN(2,I) = LOG(Y(I)) C *** AND YN(I,J), J = N+1(1)2*N, I = 1 OR 2 = SCRATCH C 180 DO 190 I = 1, N IF (R(I) .LT. ZERO) R(I) = -R(I) 190 CONTINUE CALL PRGRH1(N, PT, R, RHO, MDL, YN) C 999 RETURN END SUBROUTINE DEVIAN(F, MODEL0, N, NW, PT, YN) INTEGER MODEL0, N, NW DOUBLE PRECISION F, PT(2), YN(2,N) DOUBLE PRECISION DATAN, DLOG INTEGER I, MODEL DOUBLE PRECISION CI, D, S, T, T1, YI DOUBLE PRECISION EIGHT, HALF, ONE, TWO, ZERO DATA EIGHT/8.D+0/, HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, 1 ZERO/0.D+0/ C C *** BODY *** C D = F MODEL = IABS(MODEL0) IF (MODEL .LT. 5) GO TO 20 IF (MODEL .GT. 9) GO TO (40, 60, 999, 80) MODEL - 9 C C *** BINOMIAL DEVIANCE *** C DO 10 I = 1, N YI = YN(1,I) CI = YN(2,I) T = YI / CI IF (T .GT. ZERO) D = D + YI*DLOG(T) IF (T .LT. ONE) D = D + (CI-YI)*DLOG(ONE-T) 10 CONTINUE GO TO 100 C C *** POISSON DEVIANCE *** C 20 DO 30 I = 1, N YI = YN(1,I) IF (YI .GT. ZERO) D = D + YI*(DLOG(YI/YN(2,I)) - ONE) 30 CONTINUE GO TO 100 C C *** GAMMA DEVIANCE *** C 40 DO 50 I = 1, N YI = YN(1,I) IF (YI .LE. ZERO) GO TO 999 D = D - YN(2,I)*(ONE + DLOG(YI)) 50 CONTINUE GO TO 100 C C *** PREGIBON DEVIANCE, REPLICATE WEIGHTS *** C 60 T = PT(2) T1 = DLOG(EIGHT*DATAN(ONE)*PT(1)) S = ZERO DO 70 I = 1, N 70 S = S + YN(2,I) * (T*DLOG(DBLE(YN(1,I))) + T1) D = PT(1) * (D - HALF*S) GO TO 100 C C *** PREGIBON DEVIANCE, VARIANCE WEIGHTS *** C 80 S = ZERO T = ZERO DO 90 I = 1, N S = S + DLOG(DBLE(YN(1,I))) T = T + DLOG(DBLE(YN(2,I))) 90 CONTINUE D = PT(1) * (D - 1 HALF*(PT(2)*S - T + N*DLOG(EIGHT*DATAN(ONE)*PT(1)))) C 100 WRITE(NW,*) 'DEVIANCE = ', TWO*D 999 RETURN END DOUBLE PRECISION FUNCTION DZERO(F,A,B,T) C *** THE PORT ROUTINE, MODIFIED TO STOP RATHER THAN CALLING SETERR *** C *** AND TO CALL DR7MDC RATHER THAN D1MACH *** C C FINDS THE REAL ROOT OF THE FUNCTION F LYING BETWEEN A AND B C TO WITHIN A TOLERANCE OF C C 6*D1MACH(3) * ABS(DZERO) + 2 * T C C F(A) AND F(B) MUST HAVE OPPOSITE SIGNS C C THIS IS BRENTS ALGORITHM C C A, STORED IN SA, IS THE PREVIOUS BEST APPROXIMATION (I.E. THE OLD B) C B, STORED IN SB, IS THE CURRENT BEST APPROXIMATION C C IS THE MOST RECENTLY COMPUTED POINT SATISFYING F(B)*F(C) .LT. 0 C D CONTAINS THE CORRECTION TO THE APPROXIMATION C E CONTAINS THE PREVIOUS VALUE OF D C M CONTAINS THE BISECTION QUANTITY (C-B)/2 C DOUBLE PRECISION F,A,B,T,TT,SA,SB,C,D,E,FA,FB,FC,TOL,M,P,Q,R,S EXTERNAL F DOUBLE PRECISION DR7MDC C TT = T IF (T .LE. 0.0D0) TT = 10.D0*DR7MDC(1) C SA = A SB = B FA = F(SA) FB = F(SB) IF (FA .NE. 0.0D0) GO TO 5 DZERO = SA RETURN 5 IF (FB .EQ. 0.0D0) GO TO 140 IF (DSIGN(FA,FB) .EQ. FA) THEN WRITE(*,*) 'DZERO: F(A) = ', FA, '; F(B) = ', FB STOP END IF C 10 C = SA FC = FA E = SB-SA D = E C C INTERCHANGE B AND C IF ABS F(C) .LT. ABS F(B) C 20 IF ( ABS(FC).GE. ABS(FB)) GO TO 30 SA = SB SB = C C = SA FA = FB FB = FC FC = FA C 30 TOL = 2.0D0*DR7MDC(3)* ABS(SB)+TT M = 0.5D0*(C-SB) C C SUCCESS INDICATED BY M REDUCES TO UNDER TOLERANCE OR C BY F(B) = 0 C IF (( ABS(M).LE.TOL).OR.(FB.EQ.0.0D0)) GO TO 140 C C A BISECTION IS FORCED IF E, THE NEXT-TO-LAST CORRECTION C WAS LESS THAN THE TOLERANCE OR IF THE PREVIOUS B GAVE C A SMALLER F(B). OTHERWISE GO TO 40. C IF (( ABS(E).GE.TOL).AND.( ABS(FA).GE. ABS(FB))) GO TO 40 E = M D = E GO TO 100 40 S = FB/FA C C QUADRATIC INTERPOLATION CAN ONLY BE DONE IF A (IN SA) C AND C ARE DIFFERENT POINTS. C OTHERWISE DO THE FOLLOWING LINEAR INTERPOLATION C IF (SA.NE.C) GO TO 50 P = 2.0D0*M*S Q = 1.0D0-S GO TO 60 C C INVERSE QUADRATIC INTERPOLATION C 50 Q = FA/FC R = FB/FC P = S*(2.0D0*M*Q*(Q-R)-(SB-SA)*(R-1.0D0)) Q = (Q-1.0D0)*(R-1.0D0)*(S-1.0D0) 60 IF (P.LE.0.0D0) GO TO 70 Q = -Q GO TO 80 70 P = -P C C UPDATE THE QUANTITIES USING THE NEWLY COMPUTED C INTERPOLATE UNLESS IT WOULD EITHER FORCE THE C NEW POINT TOO FAR TO ONE SIDE OF THE INTERVAL C OR WOULD REPRESENT A CORRECTION GREATER THAN C HALF THE PREVIOUS CORRECTION. C C IN THESE LAST TWO CASES - DO THE BISECTION C BELOW (FROM STATEMENT 90 TO 100) C 80 S = E E = D IF ((2.0D0*P.GE.3.0D0*M*Q- ABS(TOL*Q)).OR. 1 (P.GE. ABS(0.5D0*S*Q))) GO TO 90 D = P/Q GO TO 100 90 E = M D = E C C SET A TO THE PREVIOUS B C 100 SA = SB FA = FB C C IF THE CORRECTION TO BE MADE IS SMALLER THAN C THE TOLERANCE, JUST TAKE A DELTA STEP (DELTA=TOLERANCE) C B = B + DELTA * SIGN(M) C IF ( ABS(D).LE.TOL) GO TO 110 SB = SB+D GO TO 130 C 110 IF (M.LE.0.0D0) GO TO 120 SB = SB+TOL GO TO 130 C 120 SB = SB-TOL 130 FB = F(SB) C C IF F(B) AND F(C) HAVE THE SAME SIGN ONLY C LINEAR INTERPOLATION (NOT INVERSE QUADRATIC) C CAN BE DONE C IF ((FB.GT.0.0D0).AND.(FC.GT.0.0D0)) GO TO 10 IF ((FB.LE.0.0D0).AND.(FC.LE.0.0D0)) GO TO 10 GO TO 20 C C***SUCCESS*** 140 DZERO = SB RETURN END DOUBLE PRECISION FUNCTION INVCN(X, ERRFLG) DOUBLE PRECISION X INTEGER ERRFLG COMMON /INVCMN/ XC, TOL, NCALL DOUBLE PRECISION XC, TOL INTEGER NCALL DOUBLE PRECISION CNERR, DZERO, PNORMS, DR7MDC EXTERNAL CNERR, PNORMS, DR7MDC DOUBLE PRECISION A, B DOUBLE PRECISION HALF, ONE, ZERO LOGICAL FIRST DOUBLE PRECISION HUGE PARAMETER (HALF = 0.5D+0, ONE = 1.D+0, ZERO = 0.D+0) SAVE FIRST, HUGE DATA FIRST/.TRUE./, HUGE/0.D+0/ IF (FIRST) THEN TOL = 10.D+0 * DR7MDC(1) HUGE = 0.1D+0 * DR7MDC(6) FIRST = .FALSE. END IF NCALL = 0 ERRFLG = 0 IF (X .LE. ZERO) THEN C IF (X .EQ. ZERO) THEN C INVCN = -HUGE C GO TO 999 C END IF ERRFLG = 1 INVCN = ZERO GO TO 999 END IF IF (X .GE. ONE) THEN C IF (X .EQ. ONE) THEN C INVCN = HUGE C GO TO 999 C END IF ERRFLG = 1 INVCN = ZERO GO TO 999 END IF IF (X .GE. HALF) THEN A = ZERO B = ONE 10 IF (PNORMS(B) .LT. X) THEN B = B + ONE GO TO 10 END IF ELSE B = ZERO A = -ONE 20 IF (PNORMS(A) .GT. X) THEN A = A - ONE GO TO 20 END IF END IF XC = X INVCN = DZERO(CNERR,A,B,TOL) 999 RETURN END DOUBLE PRECISION FUNCTION CNERR(X) DOUBLE PRECISION X COMMON /INVCMN/ XC, TOL, NCALL DOUBLE PRECISION XC, TOL INTEGER NCALL DOUBLE PRECISION PNORMS EXTERNAL PNORMS NCALL = NCALL + 1 CNERR = XC - PNORMS(X) END SUBROUTINE LOUCHK(KDIAG, DGLG, X0, N, P, PS, X, RHPOIL, MDL, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ1) EXTERNAL DGLG, RHPOIL, BRJ, BRJ1 INTEGER KDIAG, N, P, PS, LIV, LV INTEGER IV(LIV), MDL(2), UI(*) DOUBLE PRECISION X0(P), X(P), V(LV), A(*), YN(N) C C *** DUMMY REPLACEMENT FOR C ROUTINE (USED FOR DEBUGGING) *** C END DOUBLE PRECISION FUNCTION PNORMS(X) DOUBLE PRECISION X EXTERNAL MECDF DOUBLE PRECISION D(1), PROB, RHO(1) INTEGER IER D(1) = X CALL MECDF(1, D, RHO, PROB, IER) PNORMS = 1.D+0 - PROB END SUBROUTINE POISX0(A, C, LA, LC, MODEL, N, P, QTR, X, YN) INTEGER LA, LC, MODEL, N, P DOUBLE PRECISION A(LA,N), C(LC), QTR(P), X(P), YN(2,N) EXTERNAL DL7ITV, DL7SVX, DL7SVN,DQ7ADR, DR7MDC, DV7SCL, DV7SCP DOUBLE PRECISION DL7SVX, DL7SVN, DR7MDC INTEGER I DOUBLE PRECISION SX, W, WRT, WY, YN1 DOUBLE PRECISION HALF, ONE, ZERO DATA HALF/0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ C C *** BODY *** C CALL DV7SCP(LC, C, ZERO) CALL DV7SCP(P, QTR, ZERO) DO 30 I = 1, N W = YN(2,I) IF (W .LE. ZERO) GO TO 40 WRT = SQRT(W) YN1 = YN(1,I) / YN(2,I) IF (MODEL .EQ. 2) GO TO 10 WY = WRT * YN1 GO TO 20 10 WY = WRT * DLOG( MAX(YN1, HALF/W)) 20 CALL DV7SCL(P, X, WRT, A(1,I)) CALL DQ7ADR(P, QTR, C, X, WY) 30 CONTINUE SX = DL7SVX(P, C, X, X) IF (SX .LE. ZERO) GO TO 40 IF (DL7SVN(P, C, X, X)/SX .LE. DR7MDC(3)) GO TO 40 CALL DL7ITV(P, X, C, QTR) GO TO 999 40 W = ONE IF (MODEL .EQ. 2) W = ZERO CALL DV7SCP(P, X, W) C 999 RETURN END SUBROUTINE POIX0(A, IV, LA, LIV, LV, MODEL, N, P, V, X, YN) C C *** COMPUTE INITIAL X OF E. L. FROME *** C INTEGER LA, LIV, LV, MODEL, N, P INTEGER IV(LIV) DOUBLE PRECISION X(P), A(LA,N), V(LV), YN(2,N) C EXTERNAL DIVSET, POISX0, DV7SCP C C *** LOCAL VARIABLES *** C INTEGER C1, PP1O2, QTR1, TEMP1 DOUBLE PRECISION ONE, ZERO C C *** IV COMPONENTS *** C INTEGER LMAT PARAMETER (LMAT=42) DATA ONE/1.D+0/, ZERO/0.D+0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V) C C1 = IV(LMAT) PP1O2 = P * (P + 1) / 2 QTR1 = C1 + PP1O2 TEMP1 = QTR1 + P IF (TEMP1 .GT. LV) GO TO 10 CALL POISX0(A, V(C1), LA, P*(P+1)/2, MODEL, N, P, V(QTR1), X, YN) GO TO 999 C 10 IF (MODEL .GT. 1) GO TO 20 CALL DV7SCP(P, X, ONE) GO TO 999 20 CALL DV7SCP(P, X, ZERO) C 999 RETURN END SUBROUTINE PREGRH(DERIV, F, N, NF, PT, R, RD, RHOI, YLOG, YN, ZN) C C *** RHO FOR PREGIBON ERROR MODELS WITH REPLICATE WEIGHTS *** C *** SEE PREGRV FOR THE RIGHT WEIGHTING FOR THE INSURANCE EXAMPLE *** C INTEGER DERIV, N, NF, RHOI(*) DOUBLE PRECISION F, PT(3), R(*), RD(*), YLOG(*), YN(2,N), ZN(3,N) EXTERNAL DR7MDC DOUBLE PRECISION DR7MDC C C *** LOCAL VARIABLES *** C INTEGER I, K, KMP, KMPS, KMT, KPP, KPPS, KPSPS, KPT, KTT, KTPS DOUBLE PRECISION F1, MU, PHI, PHII2, PHII3, PHIINV, PSI, PSPHII, 1 RI, RL, RP0, RPP0, RT1, RT1L, RT2, RT2L, RTOL, T, 2 T1, T1INV, T1INV2, T2, T2INV, T2INV2, THETA, TT, 3 WI, WOVPHI, YI, YL, YT1, YT1L, YT2, YT2L C DOUBLE PRECISION BIG, BIGH, TWOPI DOUBLE PRECISION BTOL, EIGHT, HALF, ONE, THREE, TWO, ZERO DATA BIG/0.D+0/, BIGH/0.D+0/, TWOPI/0.D+0/ DATA BTOL/1.01D+0/, EIGHT/8.D+0/, HALF/0.5D+0/, ONE/1.D+0/, 1 THREE/3.D+0/, TWO/2.D+0/, ZERO/0.D+0/ C C *** BODY *** C IF (NF .GT. 1) GO TO 20 IF (DERIV .GT. 0) GO TO 20 DO 10 I = 1, N 10 YLOG(I) = DLOG(YN(1,I)) 20 PHI = PT(1) PSI = PT(3) IF (PHI .LE. ZERO) GO TO 240 THETA = PT(2) IF (TWOPI .GT. ZERO) GO TO 30 TWOPI = EIGHT * DATAN(ONE) BIGH = DR7MDC(5) BIG = DR7MDC(6) 30 T2 = TWO - THETA T1 = ONE - THETA IF (DERIV .GT. 0) GO TO 120 RTOL = BIG IF (T2 .LT. BTOL) GO TO 40 RTOL = BIGH**(ONE/T2) RTOL = RTOL*RTOL 40 T = DLOG(TWOPI * PHI) F = ZERO DO 50 I = 1, N 50 F = F + YN(2,I)*(T + THETA*YLOG(I)) F1 = ZERO IF (THETA .EQ. ONE) GO TO 70 IF (THETA .EQ. TWO) GO TO 90 T1INV = ONE / T1 T2INV = ONE / T2 DO 60 I = 1, N RI = R(I) IF (RI .GE. RTOL) GO TO 240 IF (RI .LE. ZERO) GO TO 240 YI = YN(1,I) RT1 = RI**(T1*PSI) ZN(2,I) = RT1 YT1 = YI**T1 ZN(3,I) = YT1 T = T2INV*(RI**(T2*PSI) - YI*YT1) + YI*T1INV*(YT1 - RT1) F1 = F1 + T*YN(2,I) ZN(1,I) = T 60 CONTINUE GO TO 110 C C *** THETA == 1 *** C 70 DO 80 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 240 MU = RI**PSI YI = YN(1,I) T = MU - YI - YI*DLOG(MU/YI) F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = ONE 80 CONTINUE GO TO 110 C C *** THETA == 2 *** C 90 DO 100 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 240 T1 = RI**(-PSI) YI = YN(1,I) * T1 T = YI - DLOG(YI) - ONE F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = T1 100 CONTINUE 110 F = HALF*F + F1/PHI GO TO 999 C C *** GRADIENT COMPUTATIONS *** C 120 PHIINV = ONE / PHI PHII2 = PHIINV * PHIINV RP0 = HALF * PHIINV RPP0 = -PHIINV * RP0 PHII3 = TWO * PHIINV * PHII2 KMP = N KPP = N + N T1 = ONE - THETA T2 = TWO - THETA IF (RHOI(2) .LE. RHOI(3)+2) GO TO 140 C C *** PSI DERIVATIVES *** C K = KPP + N KMPS = 6*N KPPS = KMPS + N KTPS = KPPS + N KPSPS = KTPS + N DO 130 I = 1, N WI = YN(2,I) RI = R(I) MU = RI**PSI RL = DLOG(RI) RT1 = WI * ZN(2,I) RT2 = RT1 * MU YI = YN(1,I) T = (RL/PHI) * (RT2 - YI*RT1) K = K + 1 R(K) = T KMPS = KMPS + 1 TT = RL * (T2*RT2 - YI*T1*RT1) RD(KMPS) = (RT2 - YI*RT1 + PSI*TT) / (RI*PHI) KPPS = KPPS + 1 RD(KPPS) = -T / PHI KTPS = KTPS + 1 RD(KTPS) = -PSI * RL * T KPSPS = KPSPS + 1 RD(KPSPS) = TT * RL / PHI 130 CONTINUE C 140 IF (RHOI(2) .LE. RHOI(3)) GO TO 220 IF (RHOI(2) .EQ. RHOI(3)+1) GO TO 200 C C *** THETA DERIVATIVES *** C K = KPP KMT = K + N KPT = KMT + N KTT = KPT + N IF (THETA .EQ. ONE) GO TO 160 IF (THETA .EQ. TWO) GO TO 180 T1INV = ONE / T1 T1INV2 = T1INV + T1INV T2INV = ONE / T2 T2INV2 = T2INV + T2INV DO 150 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV RI = R(I) MU = RI**PSI RT1 = ZN(2,I) RT2 = RT1 * MU RL = DLOG(MU) RT1L = RT1 * RL RT2L = RT2 * RL YI = YN(1,I) YT1 = ZN(3,I) YT2 = YT1 * YI YL = YLOG(I) YT1L = YT1 * YL YT2L = YT2 * YL T = PHIINV * (YI * T1INV * (RL*RT1 - YL*YT1 + 1 T1INV*(YT1 - RT1)) 2 + T2INV * (YL*YT2 - RL*RT2 + 3 T2INV*(RT2 - YT2))) K = K + 1 R(K) = WI * (HALF*YL + T) KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI*RT1 - RT2) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 RD(KTT) = WOVPHI*(T1INV*YI*(YT1L*YL - RT1L*RL + 1 T1INV2*(RT1L - YT1L + 2 T1INV*(YT1 - RT1))) + 3 T2INV*(RT2L*RL - YT2L*YL + 4 T2INV2*(YT2L - RT2L + 5 T2INV*(RT2 - YT2)))) 150 CONTINUE GO TO 200 C C *** THETA DERIVATIVES AT THETA == 1 *** C 160 DO 170 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = DLOG(MU) K = K + 1 T = HALF*YI*(RL*RL - YL*YL) + YI*YL - MU*RL + MU - YI R(K) = WI*(HALF*YL + T) KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI - MU) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ( MU * (TWO - TWO*RL + T) 1 -YI*(TWO - T*RL/THREE + YL*(YL - TWO + YL*YL/THREE))) 170 CONTINUE GO TO 200 C C *** THETA DERIVATIVES AT THETA == 2 *** C 180 DO 190 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = DLOG(MU) K = K + 1 T = HALF*(YL*YL - RL*RL) + YL + ONE - (YI + YI*RL)/MU R(K) = WI*(HALF*YL + T) KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI/MU - ONE) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ((YL/MU)*(T + TWO*RL + TWO) - TWO 1 - YL*(TWO + YL*(ONE + YL/THREE)) + T*RL/THREE) 190 CONTINUE C C *** PHI AND MU DERIVATIVES *** C 200 K = N THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE PSPHII = PSI * PHIINV PHIINV = -PHIINV DO 210 I = 1, N WI = YN(2,I) WOVPHI = WI * PSPHII RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI T2 = WOVPHI * RT1 * (MU - YI) R(I) = T2 RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI T = ZN(1,I) K = K + 1 R(K) = WI * (RP0 - PHII2*T) KMP = KMP + 1 RD(KMP) = PHIINV * T2 KPP = KPP + 1 RD(KPP) = WI * (RPP0 + PHII3*T) 210 CONTINUE GO TO 999 C C *** JUST MU DERIVATIVES *** C 220 PHIINV = PHIINV * PSI THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE DO 230 I = 1, N WOVPHI = YN(2,I) * PHIINV RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI R(I) = WOVPHI * RT1 * (MU - YI) RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI 230 CONTINUE GO TO 999 C 240 NF = 0 C 999 RETURN END SUBROUTINE PREGRV(DERIV, F, N, NF, PT, R, RD, RHOI, YLOG, YN, ZN) C C *** RHO FOR PREGIBON ERROR MODELS WITH VARIANCE WEIGHTS *** C INTEGER DERIV, N, NF, RHOI(*) DOUBLE PRECISION F, PT(3), R(*), RD(*), YLOG(N+2),YN(2,N),ZN(3,N) EXTERNAL DR7MDC DOUBLE PRECISION DR7MDC C C *** LOCAL VARIABLES *** C INTEGER I, K, KMP, KMPS, KMT, KPP, KPPS, KPSPS, KPT, KTT, KTPS DOUBLE PRECISION F1, MU, PHI, PHII2, PHII3, PHIINV, PSI, PSPHII, 1 RI, RL, RP0, RPP0, RT1, RT1L, RT2, RT2L, RTOL, T, 2 T1, T1INV, T1INV2, T2, T2INV, T2INV2, THETA, TT, 3 WI, WOVPHI, YI, YL, YT1, YT1L, YT2, YT2L C DOUBLE PRECISION BIG, BIGH, TWOPI DOUBLE PRECISION BTOL, EIGHT, HALF, ONE, THREE, TWO, ZERO DATA BIG/0.D+0/, BIGH/0.D+0/, TWOPI/0.D+0/ DATA BTOL/1.01D+0/, EIGHT/8.D+0/, HALF/0.5D+0/, ONE/1.D+0/, 1 THREE/3.D+0/, TWO/2.D+0/, ZERO/0.D+0/ C C *** BODY *** C PHI = PT(1) IF (PHI .LE. ZERO) GO TO 230 IF (TWOPI .GT. ZERO) GO TO 10 TWOPI = EIGHT * DATAN(ONE) BIGH = DR7MDC(5) BIG = DR7MDC(6) 10 IF (NF .GT. 1) GO TO 30 IF (DERIV .GT. 0) GO TO 30 T1 = ZERO T2 = ZERO DO 20 I = 1, N T = DLOG(YN(1,I)) YLOG(I) = T T1 = T1 + T T2 = T2 + DLOG(YN(2,I)) 20 CONTINUE YLOG(N+1) = T1 YLOG(N+2) = -T2 30 PSI = PT(3) THETA = PT(2) T2 = TWO - THETA T1 = ONE - THETA IF (DERIV .GT. 0) GO TO 110 RTOL = BIG IF (T2 .LT. BTOL) GO TO 40 RTOL = BIGH**(ONE/T2) RTOL = RTOL*RTOL 40 F = N*DLOG(TWOPI*PHI) + YLOG(N+2) + THETA*YLOG(N+1) F1 = ZERO IF (THETA .EQ. ONE) GO TO 60 IF (THETA .EQ. TWO) GO TO 80 T1INV = ONE / T1 T2INV = ONE / T2 DO 50 I = 1, N RI = R(I) IF (RI .GE. RTOL) GO TO 230 IF (RI .LE. ZERO) GO TO 230 YI = YN(1,I) RT1 = RI**(T1*PSI) ZN(2,I) = RT1 YT1 = YI**T1 ZN(3,I) = YT1 T = T2INV*(RI**(T2*PSI) - YI*YT1) + YI*T1INV*(YT1 - RT1) F1 = F1 + T*YN(2,I) ZN(1,I) = T 50 CONTINUE GO TO 100 C C *** THETA == 1 *** C 60 DO 70 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 230 MU = RI**PSI YI = YN(1,I) T = MU - YI - YI*DLOG(MU/YI) F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = ONE 70 CONTINUE GO TO 100 C C *** THETA == 2 *** C 80 DO 90 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 230 T1 = RI**(-PSI) YI = YN(1,I) * T1 T = YI - DLOG(YI) - ONE F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = T1 90 CONTINUE 100 F = HALF*F + F1/PHI GO TO 999 C C *** GRADIENT COMPUTATIONS *** C 110 PHIINV = ONE / PHI PHII2 = PHIINV * PHIINV RP0 = HALF * PHIINV RPP0 = -PHIINV * RP0 PHII3 = TWO * PHIINV * PHII2 KMP = N KPP = N + N T1 = ONE - THETA T2 = TWO - THETA IF (RHOI(2) .LE. RHOI(3)+2) GO TO 130 C C *** PSI DERIVATIVES *** C K = KPP + N KMPS = 6*N KPPS = KMPS + N KTPS = KPPS + N KPSPS = KTPS + N DO 120 I = 1, N WI = YN(2,I) RI = R(I) MU = RI**PSI RL = DLOG(RI) RT1 = WI * ZN(2,I) RT2 = RT1 * MU YI = YN(1,I) T = (RL/PHI) * (RT2 - YI*RT1) K = K + 1 R(K) = T KMPS = KMPS + 1 TT = RL * (T2*RT2 - YI*T1*RT1) RD(KMPS) = (RT2 - YI*RT1 + PSI*TT) / (RI*PHI) KPPS = KPPS + 1 RD(KPPS) = -T / PHI KTPS = KTPS + 1 RD(KTPS) = -PSI * RL * T KPSPS = KPSPS + 1 RD(KPSPS) = TT * RL / PHI 120 CONTINUE C 130 IF (RHOI(2) .LE. RHOI(3)) GO TO 210 IF (RHOI(2) .EQ. RHOI(3)+1) GO TO 190 C C *** THETA DERIVATIVES *** C K = KPP KMT = K + N KPT = KMT + N KTT = KPT + N IF (THETA .EQ. ONE) GO TO 150 IF (THETA .EQ. TWO) GO TO 170 T1INV = ONE / T1 T1INV2 = T1INV + T1INV T2INV = ONE / T2 T2INV2 = T2INV + T2INV DO 140 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV RI = R(I) MU = RI**PSI RT1 = ZN(2,I) RT2 = RT1 * MU RL = DLOG(MU) RT1L = RT1 * RL RT2L = RT2 * RL YI = YN(1,I) YT1 = ZN(3,I) YT2 = YT1 * YI YL = YLOG(I) YT1L = YT1 * YL YT2L = YT2 * YL T = PHIINV * (YI * T1INV * (RL*RT1 - YL*YT1 + 1 T1INV*(YT1 - RT1)) 2 + T2INV * (YL*YT2 - RL*RT2 + 3 T2INV*(RT2 - YT2))) K = K + 1 R(K) = HALF*YL + WI*T KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI*RT1 - RT2) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 RD(KTT) = WOVPHI*(T1INV*YI*(YT1L*YL - RT1L*RL + 1 T1INV2*(RT1L - YT1L + 2 T1INV*(YT1 - RT1))) + 3 T2INV*(RT2L*RL - YT2L*YL + 4 T2INV2*(YT2L - RT2L + 5 T2INV*(RT2 - YT2)))) 140 CONTINUE GO TO 190 C C *** THETA DERIVATIVES AT THETA == 1 *** C 150 DO 160 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = DLOG(MU) K = K + 1 T = HALF*YI*(RL*RL - YL*YL) + YI*YL - MU*RL + MU - YI R(K) = HALF*YL + WI*T KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI - MU) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ( MU * (TWO - TWO*RL + T) 1 -YI*(TWO - T*RL/THREE + YL*(YL - TWO + YL*YL/THREE))) 160 CONTINUE GO TO 190 C C *** THETA DERIVATIVES AT THETA == 2 *** C 170 DO 180 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = DLOG(MU) K = K + 1 T = HALF*(YL*YL - RL*RL) + YL + ONE - (YI + YI*RL)/MU R(K) = HALF*YL + WI*T KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI/MU - ONE) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ((YL/MU)*(T + TWO*RL + TWO) - TWO 1 - YL*(TWO + YL*(ONE + YL/THREE)) + T*RL/THREE) 180 CONTINUE C C *** PHI AND MU DERIVATIVES *** C 190 K = N THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE PSPHII = PSI * PHIINV PHIINV = -PHIINV DO 200 I = 1, N WI = YN(2,I) WOVPHI = WI * PSPHII RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI T2 = WOVPHI * RT1 * (MU - YI) R(I) = T2 RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI T = ZN(1,I) K = K + 1 R(K) = RP0 - WI*PHII2*T KMP = KMP + 1 RD(KMP) = PHIINV * T2 KPP = KPP + 1 RD(KPP) = RPP0 + WI*PHII3*T 200 CONTINUE GO TO 999 C C *** JUST MU DERIVATIVES *** C 210 PHIINV = PHIINV * PSI THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE DO 220 I = 1, N WOVPHI = YN(2,I) * PHIINV RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI R(I) = WOVPHI * RT1 * (MU - YI) RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI 220 CONTINUE GO TO 999 C 230 NF = 0 C 999 RETURN END SUBROUTINE PRGRH1(N, PT, R, RHO, RHOI, YN) C C *** RHO FOR PREGIBON ERROR MODELS *** C INTEGER N, RHOI(3) DOUBLE PRECISION PT(2), R(*), RHO(N), YN(2,N) C *** LOCAL VARIABLES *** C INTEGER I DOUBLE PRECISION HTHETA, PHI, RI, RT1, T, T1, T1INV, T2, T2INV, 1 THETA, YI, YT1 C DOUBLE PRECISION HALF, ONE, TWO DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/ C C *** BODY *** C PHI = PT(1) THETA = PT(2) HTHETA = HALF * THETA DO 10 I = 1, N 10 RHO(I) = HTHETA*DLOG(PHI*YN(1,I)) IF (THETA .EQ. ONE) GO TO 30 IF (THETA .EQ. TWO) GO TO 50 T1 = ONE - THETA T1INV = ONE / T1 / PHI T2 = TWO - THETA T2INV = ONE / T2 / PHI DO 20 I = 1, N RI = R(I) YI = YN(1,I) RT1 = RI**T1 YT1 = YI**T1 RHO(I) = RHO(I) + T2INV*(RI*RT1 - YI*YT1) + YI*T1INV*(YT1- RT1) 20 CONTINUE GO TO 999 30 DO 40 I = 1, N RI = R(I) YI = YN(1,I) T = RI - YI - YI*DLOG(RI/YI) RHO(I) = RHO(I) + T / PHI 40 CONTINUE GO TO 999 50 DO 60 I = 1, N YI = YN(1,I) / R(I) T = YI - DLOG(YI) - ONE RHO(I) = RHO(I) + T / PHI 60 CONTINUE 999 RETURN END SUBROUTINE RHPOIL(NEED, F, N, NF, PT, R, RD, RHOI, YN, W) COMMON /FUDGE/ NFUDGE INTEGER NFUDGE INTEGER NEED(2), N, NF, RHOI(6) DOUBLE PRECISION F, PT(3), R(*), RD(*), W(N), YN(2,N) C PT = PHI AND THETA (WHEN PS == P, I.E. RHOI(2) == RHOI(3)) C DOUBLE PRECISION INVCN, LPN, PNORMS, DR7MDC EXTERNAL INVCN, LPN, PNORMS, DR7MDC INTEGER ERRFLG, I, IM, WCOMP DOUBLE PRECISION CI, E, PHI, PHIRI, PHIMRI, PSI, PSI1, PSI2, 1 RI, T, T1, T2, THETA, YI DOUBLE PRECISION DATAN, DEXP, DLOG, SQRT DOUBLE PRECISION CNN, EIGHT, EXPMAX, EXPMIN, FOUR, HALF, ONE, TWO, 1 TWOPI, ZERO DATA CNN/0.D+0/, EXPMAX/0.D+0/, EIGHT/8.D+0/, EXPMIN/0.D+0/, 1 FOUR/4.0D+0/, HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, 2 TWOPI/0.D+0/, ZERO/0.D+0/ C C *** BODY *** C IM = RHOI(1) WCOMP = RHOI(6) IF (IM .LE. 0) GO TO 800 IF (IM .GT. 13) GO TO 800 IF (EXPMAX .GT. ZERO) GO TO 10 EXPMAX = TWO * DLOG(DR7MDC(5)) EXPMIN = TWO * DLOG(DR7MDC(2)) TWOPI = EIGHT * DATAN(ONE) 10 IF (NEED(1) .EQ. 2) GO TO 240 F = ZERO GO TO (20,20,40,60,80,80,100,120,140,160,180,220,180), IM C C *** POISSON RHO (AND CONVENTIONAL IRLS) *** C 20 DO 30 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 F = F + YN(2,I)*RI - YN(1,I)*DLOG(RI) 30 CONTINUE GO TO 999 C C *** LOG LINEAR POISSON *** C 40 DO 50 I = 1, N E = ZERO RI = R(I) IF (RI .GT. EXPMAX) GO TO 800 IF (RI .GT. EXPMIN) E = EXP(RI) F = F + YN(2,I)*E - YN(1,I)*RI R(I) = E 50 CONTINUE GO TO 999 C C *** SQUARE-ROOT LINEAR POISSON *** C 60 DO 70 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 F = F + YN(2,I)*RI**2 - TWO*YN(1,1)*DLOG(RI) 70 CONTINUE GO TO 999 C C *** BINOMIAL RHO (AND CONVENTIONAL IRLS) *** C 80 DO 90 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 IF (RI .GE. ONE) GO TO 800 F = F - YN(1,I)*DLOG(RI) - (YN(2,I) - YN(1,I))*DLOG(ONE-RI) 90 CONTINUE GO TO 999 C C *** BINOMIAL LOGISTIC RHO *** C 100 DO 110 I = 1, N RI = R(I) IF (RI .GE. EXPMAX) GO TO 800 E = ZERO IF (RI .GT. EXPMIN) E = DEXP(RI) F = F + YN(2,I)*DLOG(ONE + E) - YN(1,I)*RI R(I) = E 110 CONTINUE GO TO 999 C C *** PROBIT *** C 120 DO 130 I = 1, N RI = R(I) YI = YN(1,I) F = F - YI*LPN(RI) - (YN(2,I)-YI)*LPN(-RI) 130 CONTINUE IF (NFUDGE .GT. 0) WRITE(*,*) 'NFUDGE =', NFUDGE NFUDGE = 0 GO TO 999 C C *** WEIBULL *** C 140 DO 150 I = 1, N RI = R(I) IF (RI .GE. EXPMAX) GO TO 800 E = ZERO IF (RI .GT. EXPMIN) E = DEXP(RI) R(I) = E T = ZERO IF (-E .GT. EXPMIN) T = DEXP(-E) F = F + (YN(2,I) - YN(1,I))*E - YN(1,I)*DLOG(ONE - T) 150 CONTINUE GO TO 999 C C *** GAMMA ERRORS *** C 160 DO 170 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 F = F + YN(1,I)*RI - YN(2,I)*DLOG(RI) 170 CONTINUE GO TO 999 C C *** PREGIBON ERRORS *** C C *** IN THIS CASE, YN(1,I) = Y(I), YN(2,I) = LOG(Y(I)) C *** AND YN(I,J), J = N+1(1)2*N, I = 1 OR 2 = SCRATCH C 180 IF (NF .GT. 1) GO TO 190 RHOI(4) = 0 RHOI(5) = 0 190 I = N + N + 3 C *** THE YLOG ARRAY PASSED TO PREGRV MUST BE AT LEAST N+2 LONG IF (NEED(2) .NE. RHOI(4)) GO TO 200 I = I + 3*N RHOI(5) = NF GO TO 210 200 RHOI(4) = NF 210 IF (IM .EQ. 11) THEN CALL PREGRH(0, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) ELSE CALL PREGRV(0, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) END IF GO TO 999 C C *** LEAST-SQUARES *** C 220 DO 230 I = 1, N E = R(I) - YN(1,I) F = F + E*E 230 CONTINUE F = HALF * F GO TO 999 C 240 GO TO (250,270,310,350,400,420,460,500,570,620,660,780,660), IM C C *** IRLS POISSON DERIVATIVES *** C 250 DO 260 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 R(I) = YN(2,I) - YN(1,I) / RI RD(I) = YN(2,I) / RI 260 CONTINUE GO TO 820 C C *** POISSON DERIVATIVES *** C 270 DO 300 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 YI = YN(1,I) CI = YN(2,I) E = YI / RI R(I) = CI - E RD(I) = E / RI GO TO (300, 280, 280, 290), WCOMP 280 W(I) = CI / RI GO TO 300 290 IF (YI .LE. ZERO) THEN W(I) = HALF * CI / RI ELSE T1 = CI*RI + YI*(DLOG(E/CI) - ONE) IF (T1 .NE. ZERO) THEN T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF END IF 300 CONTINUE GO TO 810 C C *** LOG LINEAR POISSON *** C 310 DO 340 I = 1, N YI = YN(1,I) CI = YN(2,I) RI = CI*R(I) R(I) = RI - YI RD(I) = RI GO TO (340,340,320,330), WCOMP 320 T = RI/YI IF (T .EQ. ONE) THEN W(I) = YI ELSE W(I) = YI * ((T - ONE) / DLOG(T)) ENDIF GO TO 340 330 T1 = RI + YI*(DLOG(YI/RI) - ONE) IF (T1 .NE. ZERO) THEN T = RI - YI W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 340 CONTINUE IF (WCOMP .LE. 2) GO TO 820 GO TO 999 C C *** SQUARE-ROOT LINEAR POISSON *** C 350 DO 390 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 YI = YN(1,I) CI = YN(2,I) E = YI / RI R(I) = TWO * (CI*RI - E) RD(I) = TWO * (CI + E/RI) GO TO (390, 360, 370, 380), WCOMP 360 W(I) = FOUR * CI GO TO 390 370 T1 = RI - SQRT(YI/CI) IF (T1 .NE. ZERO) THEN T = CI*RI - YI/RI W(I) = (T+T) / T1 ELSE W(I) = RD(I) END IF GO TO 390 380 T1 = CI*RI*RI - YI + YI*DLOG(YI/(CI*RI*RI)) IF (T1 .NE. ZERO) THEN T = CI*RI - YI/RI T = T / T1 W(I) = T + T ELSE W(I) = RD(I) END IF 390 CONTINUE GO TO 810 C C *** IRLS BINOMIAL *** C 400 DO 410 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 IF (RI .GE. ONE) GO TO 800 YI = YN(1,I) CI = YN(2,I) T = ONE / (ONE - RI) R(I) = (CI - YI) * T - YI / RI RD(I) = T * CI / RI 410 CONTINUE GO TO 820 C C *** BINOMIAL *** C 420 DO 450 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 IF (RI .GE. ONE) GO TO 800 YI = YN(1,I) T = ONE / (ONE - RI) CI = (YN(2,I) - YI) * T YI = YI / RI R(I) = CI - YI RD(I) = T*CI + YI/RI GO TO (450,430,430,440), WCOMP 430 W(I) = T*YN(2,I) / RI GO TO 450 440 YI = YN(1,I) CI = YN(2,I) T2 = YI / CI T1 = (YI - CI)*DLOG((ONE - RI)/(ONE - T2)) + YI*DLOG(T2/RI) IF (T1 .NE. ZERO) THEN T = (CI*RI - YI)/(RI * (ONE - RI)) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 450 CONTINUE GO TO 810 C C *** BINOMIAL LOGISTIC *** C 460 DO 490 I = 1, N RI = R(I) YI = YN(1,I) CI = YN(2,I) T = ONE / (ONE + RI) T1 = T * RI * CI R(I) = T1 - YI RD(I) = T * T1 GO TO (490,490,470,480), WCOMP 470 T1 = (ONE + RI)*DLOG(RI*(CI-YI)/YI) IF (T1 .NE. ZERO) THEN W(I) = ((CI - YI)*RI - YI) / T1 ELSE W(I) = RD(I) END IF GO TO 490 480 T1 = CI*DLOG((ONE+RI)*(ONE - YI/CI)) + YI*DLOG(YI/(RI*(CI-YI))) IF (T1 .NE. ZERO) THEN T = ((CI - YI)*RI - YI) / (ONE + RI) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 490 CONTINUE IF (WCOMP .LE. 2) GO TO 820 GO TO 999 C C *** PROBIT *** C 500 IF (CNN .LE. ZERO) CNN = ONE / SQRT(TWOPI) DO 560 I = 1, N RI = R(I) YI = YN(1,I) CI = YN(2,I) - YI E = ZERO T = -HALF * RI**2 IF (T .GT. EXPMIN) E = CNN * DEXP(T) PHIRI = PNORMS(RI) IF (WCOMP .EQ. 2) 1 W(I) = YN(2,I) * (E / PHIRI) * (E / (ONE - PHIRI)) IF (PHIRI .LE. ZERO) GO TO 510 PHIRI = ONE / PHIRI T1 = E*PHIRI*YI T2 = T1*(RI + PHIRI*E) T1 = -T1 GO TO 520 510 T1 = YI * (RI + ONE/RI) T2 = YI * (ONE - ONE/RI**2) 520 PHIMRI = PNORMS(-RI) IF (PHIMRI .LE. ZERO) GO TO 530 PHIMRI = ONE / PHIMRI T = E*CI*PHIMRI R(I) = T + T1 RD(I) = T*(PHIMRI*E - RI) + T2 GO TO (560,560,540,550), WCOMP 530 R(I) = CI*(RI + ONE/RI) + T1 RD(I) = CI*(ONE - ONE/RI**2) + T2 GO TO (560,560,540,550), WCOMP 540 T = RI - INVCN(YI/YN(2,I), ERRFLG) IF (ERRFLG .NE. 0) THEN WRITE(*,*) 'ERROR FROM INVCN: I, YI, YN(1,I), YN(2,I) =' 1 , I, YI, YN(1,I), YN(2,I) GO TO 800 END IF IF (T .NE. ZERO) THEN W(I) = R(I) / T ELSE W(I) = RD(I) END IF GO TO 560 550 T2 = CI CI = YN(2,I) T1 = T2*(DLOG(T2/CI) - LPN(-RI)) IF (YI .GT. ZERO) T1 = T1 + YI*(DLOG(YI/CI) - LPN(RI)) IF (T1 .NE. ZERO) THEN T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 560 CONTINUE GO TO 810 C C *** WEIBULL *** C 570 DO 610 I = 1, N RI = R(I) E = ZERO IF (-RI .GT. EXPMIN) E = DEXP(-RI) T = RI / (ONE - E) CI = YN(2,I)*RI YI = YN(1,I)*T R(I) = CI - YI RD(I) = CI - YI*(ONE - E*T) GO TO (570,580,590,600), WCOMP 580 W(I) = E*CI*RI / (ONE - E) GO TO 610 590 T1 = DLOG(-RI / DLOG(ONE - YN(1,I)/YN(2,I))) IF (T1 .NE. ZERO) THEN W(I) = (CI - YI) / T1 ELSE W(I) = RD(I) END IF GO TO 610 600 YI = YN(1,I) CI = YN(2,I) T2 = YI / CI CI = CI - YI T1 = CI*(RI + DLOG(ONE - T2)) + YI*(DLOG(T2/(ONE - E))) IF (T1 .NE. ZERO) THEN T = CI - YI W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 610 CONTINUE GO TO 810 C C *** GAMMA ERRORS *** C 620 DO 650 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 C F = F + YN(1,I)*RI - YN(2,I)*DLOG(RI) T = YN(2,I)/RI T1 = ONE R(I) = YN(1,I) - T RD(I) = T/RI GO TO (650,650,630,640), WCOMP 630 W(I) = YN(1,I) / RI GO TO 650 640 T2 = YN(1,I) * RI / YN(2,I) T1 = T2 - ONE T = T1*RD(I)*T1 IF (T .GT. ZERO) THEN T2 = T1 - DLOG(T2) T = T / (T2+T2) END IF W(I) = T 650 CONTINUE IF (WCOMP .LE. 2) GO TO 820 GO TO 999 C C *** PREGIBON ERRORS *** C 660 IF (WCOMP .GE. 2) CALL DV7CPY(N, W, R) I = N + N + 3 IF (RHOI(4) .EQ. NF) GO TO 670 I = I + 3*N IF (RHOI(5) .EQ. NF) GO TO 670 WRITE(6,*) 'HELP! NF =', NF, ' BUT RHOI =', RHOI GO TO 800 670 IF (IM .EQ. 11) THEN CALL PREGRH(1, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) ELSE CALL PREGRV(1, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) END IF IF (NF .EQ. 0) GO TO 999 GO TO (820,680,700,720), WCOMP 680 PSI = PT(3) T = (TWO - PT(2))*PSI - TWO T1 = PSI*PSI DO 690 I = 1, N 690 W(I) = YN(2,I) * T1 * W(I)**T GO TO 999 700 T = ONE / PT(3) DO 710 I = 1, N T1 = W(I) - ONE IF (T1 .NE. ZERO) THEN YI = YN(1,I) W(I) = R(I) / (W(I) - YI**T) ELSE W(I) = RD(I) END IF 710 CONTINUE GO TO 999 720 PHI = PT(1) THETA = PT(2) PSI = PT(3) IF (THETA .EQ. ONE) GO TO 740 IF (THETA .EQ. TWO) GO TO 760 T1 = ONE - THETA T2 = TWO - THETA PSI1 = PSI * T1 PSI2 = PSI * T2 DO 730 I = 1, N RI = W(I) YI = YN(1,I) T = YI**T2 E = YN(2,I)/PHI * ((T - YI*RI**PSI1)/T1 - (T - RI**PSI2)/T2) IF (E .NE. ZERO) THEN T = R(I) W(I) = T*T / (E+E) ELSE W(I) = RD(I) END IF 730 CONTINUE GO TO 999 740 DO 750 I = 1, N RI = W(I) YI = YN(1,I) T1 = YN(2,I)/PHI * (RI**PSI - YI + YI*(DLOG(YI)-PSI*DLOG(RI))) IF (T1 .NE. ZERO) THEN T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 750 CONTINUE GO TO 999 760 DO 770 I = 1, N RI = W(I) YI = YN(1,I) T1 = YI*RI**(-PSI) - ONE + PSI*DLOG(RI) - DLOG(YI) IF (T1 .NE. ZERO) THEN T1 = T1 * YN(2,I) / PHI T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 770 CONTINUE GO TO 999 C C *** LEAST SQUARES *** C 780 DO 790 I = 1, N R(I) = R(I) - YN(1,I) RD(I) = ONE 790 CONTINUE GO TO 820 C 800 NF = 0 GO TO 999 C 810 IF (WCOMP .GT. 1) GO TO 999 820 CALL DV7CPY(N, W, RD) C 999 RETURN END DOUBLE PRECISION FUNCTION LPN(X) COMMON /FUDGE/ NFUDGE INTEGER NFUDGE DOUBLE PRECISION X EXTERNAL PNORMS DOUBLE PRECISION PNORMS DOUBLE PRECISION T DOUBLE PRECISION DLOG DOUBLE PRECISION HALF, ZERO DATA HALF/0.5D+0/, ZERO/0.D+0/ C C *** BODY *** C T = PNORMS(X) IF (T .GT. ZERO) THEN LPN = DLOG(T) ELSE NFUDGE = NFUDGE + 1 LPN = -HALF*X**2 - DLOG(-X) END IF 999 RETURN END //GO.SYSIN DD dpmain.f cat >mecdf.f <<'//GO.SYSIN DD mecdf.f' SUBROUTINE MECDF(NDIM, D, RHO, PROB, IER) INTEGER NDIM, IER DOUBLE PRECISION D(*), PROB, RHO(*) C----------------------------------------------------------------- C 6/29/90 C This subroutine is designed to calculate the MVN CDF C using the Mendell-Elston procedure as described in C Kamakura (1989). The current version is set up to go C as high as 19 dimensions (=> 20 MNP alternatives) C NOTE: Equation (15) in Kamakura has an error. C C Specifically, assume that Z is a set of random variables C with a standard normal distribution with correlations C stored in RHO (in packed form). Then this subroutine C calculates Prob[Z(1)>D(1);...; Z(NDIM) > D(NDIM)]. C----------------------------------------------------------------- DOUBLE PRECISION ALNORM, PHI EXTERNAL ALNORM, PHI INTEGER MAXALT, NMAX PARAMETER (MAXALT=20, NMAX=MAXALT-1) INTEGER I, IM1, IR, J, JM1, K, KM1 DOUBLE PRECISION PROBI, TMP DOUBLE PRECISION R(NMAX,NMAX,0:NMAX-1), SIG(NMAX,0:NMAX-1), 1 U(NMAX), UUMZ(NMAX-1), Z(NMAX,0:NMAX-1) DOUBLE PRECISION ONE, ZERO PARAMETER (ONE=1.D0, ZERO=0.D0) C----------------------------------------------------------------- C Test dimension IER = 0 IF (NDIM.GT.NMAX) THEN IER = -1 RETURN ENDIF C Set up arrays IR = 0 DO 10 I = 1, NDIM Z(I,0) = D(I) DO 10 J = 1, I-1 IR = IR + 1 R(J,I,0) = RHO(IR) 10 CONTINUE PROB = ALNORM(Z(1,0), .TRUE.) IF (PROB.LE.ZERO) THEN IER = 1 RETURN ENDIF U(1) = PHI(Z(1,0), ZERO)/PROB UUMZ(1) = U(1)*(U(1)-Z(1,0)) C Main loop DO 40 I = 2, NDIM IM1 = I-1 DO 30 J = 1, IM1 JM1 = J-1 DO 20 K = 1, JM1 KM1 = K-1 TMP = R(J,I,KM1)-R(K,J,KM1)*R(K,I,KM1)*UUMZ(K) R(J,I,K) = TMP/SIG(J,K)/SIG(I,K) 20 CONTINUE SIG(I,J) = SQRT(ONE - UUMZ(J)*R(J,I,JM1)**2) Z(I,J) = (Z(I,JM1)-U(J)*R(J,I,JM1))/SIG(I,J) 30 CONTINUE PROBI = ALNORM(Z(I,IM1), .TRUE.) IF (PROBI.LE.ZERO) THEN IER = I RETURN ENDIF PROB = PROB * PROBI IF (I.LT.NDIM) THEN U(I) = PHI(Z(I,IM1), ZERO)/PROBI UUMZ(I) = U(I)*(U(I)-Z(I,IM1)) ENDIF 40 CONTINUE END C--------------------------------------------------- DOUBLE PRECISION FUNCTION PHI(X, Y) DOUBLE PRECISION X, Y DOUBLE PRECISION ARG DOUBLE PRECISION HALF, SQ2P, XLOW, ZERO PARAMETER (HALF = 0.5D0, SQ2P = 0.91893853320467274D0, 1 XLOW = -87.D0, ZERO = 0.D0) PHI = ZERO ARG = -HALF * X * X - SQ2P - Y IF (ARG .GT. XLOW) PHI = EXP(ARG) END C--------------------------------------------------- DOUBLE PRECISION FUNCTION ALNORM(X,UPPER) DOUBLE PRECISION X LOGICAL UPPER C C ALGORITHM AS 66 BY I.D. HILL C LOGICAL UP DOUBLE PRECISION Y, Z DOUBLE PRECISION CON, HALF, LTONE, ONE, UTZERO, ZERO PARAMETER (CON=1.28D0, HALF=0.5D0, LTONE=5.D0, ONE=1.D0, 1 UTZERO=12.5D0, ZERO=0.D0) UP=UPPER Z=X IF(Z.GE.ZERO) GO TO 10 UP=.NOT.UP Z=-Z 10 IF(Z .LE. LTONE .OR. UP .AND. Z .LE. UTZERO) GO TO 20 ALNORM = ZERO GO TO 40 20 Y=HALF*Z*Z IF(Z.GT.CON) GO TO 30 ALNORM = HALF - Z * (0.398942280444D0 - 0.399903438504D0*Y/ 1 (Y + 5.75885480458D0 - 29.8213557808D0/ 2 (Y + 2.62433121679D0 + 48.6959930692D0/ 3 (Y + 5.92885724438D0)))) GO TO 40 30 ALNORM = 0.398942280385D0 * EXP(-Y)/ 1 (Z - 3.8052D-8 + 1.00000615302D0/ 2 (Z + 3.98064794D-4 + 1.98615381364D0/ 3 (Z - 0.151679116635D0 + 5.29330324926D0/ 4 (Z + 4.8385912808D0 - 15.1508972451D0/ 5 (Z + 0.742380924027D0 + 30.789933034D0/ 6 (Z + 3.99019417011D0)))))) 40 IF(.NOT.UP) ALNORM = ONE - ALNORM END //GO.SYSIN DD mecdf.f cat >mlmnp.f <<'//GO.SYSIN DD mlmnp.f' PROGRAM MLMNP C C VERSION: SEPTEMBER 4, 1991 C C *** MAXIMUM LIKELIHOOD ESTIMATION OF THE LINEAR-IN-PARAMETERS *** C *** MULTINOMIAL PROBIT MODEL (VIA MENDELL-ELSTON PROBABILITIES). *** C *** SEE REFERENCES BELOW. *** C C *** THIS VERSION DOES NOT IMPOSE SIMPLE BOUNDS ON THE PARAMETERS.*** C *** THIS VERSION DOES CALCULATE T-SCORES AND REGRESSION *** C *** DIAGNOSTICS. *** C C *** THIS PROGRAM UTILIZES A GENERAL FRAMEWORK FOR MLE OF A *** C *** PROBABILISTIC CHOICE MODEL AND MAY BE MODIFIED FOR USE WITH *** C *** OTHER CHOICE MODELS. (SEE "PROTOTYE PROGRAM" DISCUSSION.) *** C C PROGRAM MLEPCM ("PROTOTYPE PROGRAM") C *** MAXIMUM LIKELIHOOD ESTIMATION OF PROBABILISTIC CHOICE MODELS *** C C *** DESCRIPTION *** C C THIS PROGRAM PERFORMS MAXIMUM LIKELIHOOD ESTIMATION BY MINIMIZING C THE NEGATIVE OF THE LOG-LIKELIHOOD FUNCTION. THE FUNCTION IS WRITTEN C AS C C -SUM{FOR I=1, NOBS} WT(I)*LOG P[ICH(I), IX(I), RX(I)] C C WHERE: C P[ICH(I), IX(I), RX(I)] IS A GENERAL PROBABILISTIC CHOICE MODEL, C ICH(I) IS THE CHOICE MADE FOR OBSERVATION I, C IX(I) CONTAINS INTEGER EXPLANATORY DATA SPECIFIC TO OBSERVATION I C (E.G., A LIST OF ALTERNATIVES IN THE CHOICE SET), C RX(I) CONTAINS REAL EXPLANATORY DATA SPECIFIC TO OBSERVATION I, C AND WT(I) IS A WEIGHT FOR OBSERVATION I. C C THIS PROGRAM IS DESIGNED TO CALL THE GENERALIZED REGRESSION C OPTIMIZATION SUBROUTINES DGLG AND DGLGB, WHICH IN TURN CALL DRGLG C AND DRGLGB, ETC. A FEW LEVELS DOWN, THE PROBABILITY C P[ICH(I), IX(I), RX(I)] IS COMPUTED IN A USER-SUPPLIED SUBROUTINE C CALCPR, USING THE FOLLOWING CALL: C C CALL CALCPR(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, C 1 PROB, IUSER, RUSER, MNPCDF) C C FOR A DESCRIPTION OF PARAMETER USAGE, SEE THE SUBROUTINE. C C *** MLEPCM PARAMETER DECLARATIONS *** C C SCALARS: C INTEGER BS, COVTYP, ICSET, IDR, IOUNIT, NB, NFIX, NIUSER INTEGER NIVAR, NOBS, NPAR, NRUSER, NRVAR, WEIGHT, XNOTI C C ARRAYS: C INTEGER IV(300), RHOI(28000), UI(24000) DOUBLE PRECISION B(2,60), RHOR(164000), UR(160000), V(268105) DOUBLE PRECISION X(60) DOUBLE PRECISION TSTAT(60), STDERR(60) EQUIVALENCE (RHOI(1), UI(1)), (RHOR(1), UR(1)) CHARACTER*8 VNAME(60) C C LENGTHS OF ARRAYS: C INTEGER LIV, LRHOI, LRHOR, LUI, LUR, LV, LX C C INTEGER IV(LIV), RHOI(LRHOI), UI(LUI) C DOUBLE PRECISION B(2,LX), RHOR(LRHOR), UR(LUR), V(LV), X(LX) C C SUBROUTINES: C DOUBLE PRECISION DR7MDC EXTERNAL DGLG, DIVSET, DR7MDC, FPRINT, MECDF, PCMRHO, PCMRJ C C *** MLEPCM PARAMETER USAGE *** C C (SEE EXPLANATIONS BELOW) C C SCALARS: C C BS...... BLOCK-SIZE, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS ARE C REQUESTED AND ALL BLOCKS ARE THE SAME SIZE (SEE BELOW). C COVTYP.. INDICATES TYPE OF VARIANCE-COVARIANCE MATRIX APPROXIMATION. C = 1 FOR H^-1, WHERE H IS THE FINITE-DIFFERENCE HESSIAN C AT THE SOLUTION. C = 2 FOR (J^T J)^-1, I.E., THE GAUSS-NEWTON HESSIAN C APPROXIMATION AT THE SOLUTION. C ICSET... INDICATOR OF FIXED- OR VARIABLE-SIZE CHOICE SETS. C IDR..... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C IOUNIT.. OUTPUT UNIT NUMBER FOR PRINTING ERROR MESSAGES. C = FORTRAN UNIT FOR IOUNIT > 0. DEFAULT = 6. C IPRNT... INDEX INDICATING PRINT OPTIONS. C = 0 FOR NO ADDITIONAL PRINTING. C = 1 FOR FINAL CHOICE PROBABILITIES. C (DEFAULT = 0.) C NB...... NUMBER OF BLOCKS, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS C ARE REQUESTED (SEE BELOW). C NFIX.... PARAMETER USED BY DRGLG. NFIX = 0. C NIVAR... NUMBER OF (INTEGER) DATA VARIABLES PER CHOICE SET. C NIUSER.. NUMBER OF (INTEGER) USER-SPECIFIED CONSTANTS. C NOBS.... NUMBER OF OBSERVATIONS. C NPAR.... NUMBER OF MODEL PARAMETERS (X COMPONENTS). C NRVAR... NUMBER OF (REAL) DATA VARIABLES PER CHOICE SET. C NRUSER.. NUMBER OF (REAL) USER-SPECIFIED CONSTANTS. C WEIGHT.. INDICATOR FOR USER-PROVIDED WEIGHTS. C XNOTI... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C C ARRAYS AND ARRAY LENGTHS: C C B....... REAL ARRAY OF UPPER AND LOWER BOUNDS ON PARAMETER VALUES. C IV...... INTEGER VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C LIV..... LENGTH OF IV; MUST BE AT LEAST 90 + NPAR. C CURRENT LIV = 300. C LV...... LENGTH OF LV; MUST BE AT LEAST C 105 + P*(3*P + 16) + 2*N + 4P + N*(P + 2), WHERE C P = NPAR AND N = NOBS. FOR P = 60 AND N = 4000, THIS C EXPRESSION GIVES 268105. CURRENT LV = 268105. C LRHOI... LENGTH OF RHOI. CURRENT LRHOI = LUI + 4000 = 28000. C LRHOR... LENGTH OF RHOR. CURRENT LRHOR = LUR + 4000 = 164000. C LUI..... LENGTH OF UI. CURRENT LUI = 24000. C LUR..... LENGHT OF UR. CURRENT LUR = 160000. C LX...... LENGTH OF PARAMETER VECTOR X. CURRENT LX = 30. C RHOI.... INTEGER VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO PASS BLOCK-SIZES IF LEAVE-BLOCK-OUT C REGRESSION DIAGNOSTICS WITH VARIABLE BLOCK-SIZES ARE C REQUESTED (SEE BELOW). (CURRENT PCMRHO MAKES USE OF C RHOI THROUGH EQUIVALENCE OF RHOI WITH UI.) C RHOR.... REAL VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO STORE X(I) VECTORS, IF SUCH REGRESSION C DIAGNOSTICS ARE REQUESTED (SEE BELOW). (CURRENT PCMRHO C MAKES USE OF RHOR THROUGH 2EQUIVALENCE OF RHOR WITH UR.) C UI...... INTEGER VALUE ARRAY FOR USER STORAGE (SEE BELOW). C UI(1) TO UI(10) STORE MLEPCM PARAMETERS FOR USE IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C UR...... REAL VALUE ARRAY FOR USER STORAGE (SEE BELOW). C V....... REAL VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C VNAME... ARRAY OF PARAMETER NAMES FOR X COMPONENTS BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED. C C SUBROUTINES: C C PCMRJ... SUBROUTINE THAT CALCULATES GENERALIZED RESIDUAL VECTOR, C AND THE JACOBIAN OF THE GENERALIZED RESIDUAL VECTOR. C SEE DISCUSSION OF "CALCRJ" IN DGLG. C PCMRHO.. SUBROUTINE THAT CALCULATES THE CRITERION FUNCTION, AND C ITS DERIVATIVES. SEE DISCUSSION OF "RHO" IN DRGLG. C MECDF... SUBROUTINE THAT CALCULATES THE MULTIVARIATE NORMAL CDF C USING THE FIXED-ORDER MENDELL-ELSTON APPROXIMATION. C PASSED WITHOUT CHANGE TO CALCPR. (COULD BE REPLACED C WITH ANOTHER CDF ROUTINE IF DESIRED.) C C C *** DISCUSSION FOR MLEPCM *** C C *** DATA INPUT STREAM *** C C *** GENERAL PARAMETERS ARE READ IN FIRST FROM "INPUT BLOCK 1": *** C C READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT,COVTYP,IDR C C THESE PARAMETERS ARE INTENDED TO GIVE A FLEXIBLE INPUT C FORMAT FOR CHOICE MODELS, WITH SOME SHORTCUTS FOR SIMPLE CASES. C SPECIFIC SETTINGS OF THE ABOVE PARAMETERS WILL PRODUCE DIFFERENCES C IN THE INPUT STREAM FORMAT. C C FOR ICSET = 0 (OR 1) A VARIABLE NUMBER OF ALTERNATIVES PER CHOICE C SET IS USED. THE USER MUST PROVIDE THIS NUMBER FOR EACH C OBSERVATION. C FOR ICSET > 1 EACH CHOICE SET IS ASSUMED TO INCLUDE ICSET C ALTERNATIVES. C C WEIGHT = 1 MEANS THAT EACH OBSERVATION REQUIRES A WEIGHT, WHICH C MUST BE PROVIDED BY THE USER. C WEIGHT = 0 MEANS THAT ALL OBSERVATIONS AUTOMATICALLY RECEIVE EQUAL C WEIGHT AND THEREFORE NO USER-SUPPLIED WEIGHTS ARE REQUIRED. C C FOR NIVAR = -1 NO INTEGER DATA VALUES ARE REQUIRED BY THE MODEL. C FOR NIVAR = 0 A VARIABLE NUMBER OF INTEGER DATA VALUES IS STORED C PER OBSERVATION. IN THIS CASE, THE USER MUST INCLUDE FOR EACH C OBSERVATION THE NUMBER OF INTEGER VALUES TO BE STORED FOLLOWED C BY THE INTEGER VALUES THEMSELVES. (THIS MIGHT BE USED IN C CONJUNCTION WITH ICSET=0 TO LIST NOMINAL VARIABLES FOR THE C CHOICE ALTERNATIVES IN THE CHOICE SET.) C FOR NIVAR > 0 EACH OBSERVATION IS ASSUMED TO INCLUDE NIVAR INTEGERS. C C FOR NRVAR THE USAGE IS ANALOGOUS TO NIVAR, ONLY FOR REAL DATA. C C NIUSER AND NRUSER ARE USED TO INDICATE THE NUMBER OF CONSTANTS C TO BE PASSED TO THE MODEL SUBROUTINES. THESE ARE MODEL SPECIFIC. C FOR SOME CODES NIUSER, NRUSER, AND PERHAPS THE CONSTANTS, MIGHT C BE SET IN THE MAIN PROGRAM AND NOT BY THE INPUT STREAM. C C FOR MORE DETAILS ON THIS, SEE THE ACTUAL CODE BELOW. C C IN ADDITION TO DATA STORAGE, MLEPCM PROVIDES A RATHER FLEXIBLE C CHOICE OF STATISTICAL ANALYSES. IN THE VERSION OF THE PROGRAM C WHICH ENFORCES BOUNDS, STATISTICS ARE NOT CALCULATED. HOWEVER, C FOR CONVENIENCE IT IS ASSUMED THAT THE SAME INPUT STREAM IS USED C FOR BOTH PROGRAMS. C C TO CALCULATE ASYMPTOTIC T-SCORES, A VARIANCE-COVARIANCE MATRIX C APPROXIMATION IS REQUIRED. SEE COVTYP ABOVE. C C TO PERFORM REGRESSION DIAGNOSTICS, THE FOLLOWING PARAMETERS C ARE USED: C C IDR = 0 IF NO REGRESSION DIAGNOSTICS ARE DESIRED. C C = 1 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)), WHERE X(I) C MINIMIZES F (THE NEGATIVE LOG-LIKELIHOOD) WITH C OBSERVATION I REMOVED, AND X* IS THE MLE FOR THE FULL C DATASET. ("LEAVE-ONE-OUT" DIAGNOSTICS.) C C = 2 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)) AS WHEN IDR = 1, C AND ALSO THE ONE-STEP ESTIMATES OF X(I), I = 1 TO NOBS. C C = 3 FOR "LEAVE-BLOCK-OUT" DIAGNOSTICS. (DISCUSSION FOLLOWS.) C C *** PARAMETERS RELATED TO "LEAVE-BLOCK-OUT" REGRESSION DIAGNOSTICS *** C *** READ NEXT FROM "INPUT BLOCK 2" (IF APPLICABLE). *** C C "LEAVE-BLOCK-OUT" DIAGNOSTICS C C IN THIS CASE, ONE OR MORE ADDITIONAL LINES OF DATA ARE C REQUIRED. IF IDR = 3, THE FOLLOWING STATEMENT IS EXECUTED: C C READ(1,*) BS, NB, XNOTI C C NB = NUMBER OF BLOCKS C C XNOTI = 0 IF NO X(I) DIAGNOSTICS ARE REQUESTED, C = 1 OTHERWISE. C C BS > 0 MEANS THAT FIXED BLOCK SIZES OF SIZE BS ARE USED. C IN THIS CASE NB * BS = NOBS, AND THE PROGRAM C PROCEEDS TO "INPUT BLOCK 3" FOR MNP INPUT PARAMETERS. C C BS = 0 MEANS THAT VARIABLE BLOCK SIZES ARE USED. C IN THIS CASE THE NEXT FORMAT STATEMENT READS C THE BLOCK SIZES INTO RHOI USING FREE FORMAT: C C LR1 = LUI + 1 C LR2 = LR1 + NB C READ(1,*) (RHOI(I),I=LR1,LR2) C C *** THE PROGRAM THEN PROCEEDS TO "INPUT BLOCK 3" TO READ MODEL-*** C *** RELATED PARAMETERS. SEE DISCUSSION FOR MNP MODEL BELOW. *** C C *** INPUT BLOCK 4 CONTAINS THE INITIAL GUESS FOR THE SEARCH. *** C *** IT INCLUDES VARIABLE NAMES, A STARTING GUESS, AND BOUNDS. *** C C DO 10 I = 1, NPAR C READ(1,3) VNAME(I) C 3 FORMAT(1X,A8) C READ(1,*) X(I), B(1,I), B(2,I) C WRITE(IOUNIT,4) I, VNAME(I),X(I), B(1,I), B(2,I) C 4 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) C 10 CONTINUE C CLOSE(1) C C *** FOR THE LINEAR-IN-PARAMETERS MNP MODEL, THE ORDERING OF *** C *** PARAMETERS IS AS FOLLOWS: *** C C 1. MEAN TASTE WEIGHTS FOR GENERIC ATTRIBUTES (NATTR OF THESE). C 2. ALTERNATIVE-SPECIFIC MEANS (NALT-1 OF THESE). C 3. COVARIANCE PARAMETERS FOR ALTERNATIVE-SPECIFIC ERRORS. C THERE ARE 2(NALT-1)(NALT)/2 - 1 OF THESE, IN THE FORM OF C CHOLESKY DECOMPOSITION, STORED ROW-WISE: C B21 B22 C B31 B32 B33 C B(J-1,1) B(J-1,2) ..........B(J-1,J-1) C WHERE B11 = SCALE IS ASSUMED. C SEE BUNCH(1991, TRANSP. RES. B, VOL. 1, PP. 1-12); NOTE C THE MISPRINT IN EQUATION (26). C (NOTE THAT PARAMETERS ARE READ IN ONE PARAMETER PER LINE.) C 4. COVARIANCE PARAMETERS FOR TASTE VARIATION. C NATTR VARIANCES IF ITASTE=1 (UNCORRELATED). C NATTR*(NATTR+1)/2 CHOLESKY PARAMETERS IF ITASTE=2 C (I.E., CORRELATED). C C *** UNIT 1 IS CLOSED, AND THE MODEL DATA IS READ FROM UNIT 2. *** C *** ITS FORMAT IS CONTROLLED BY THE GENERAL PARAMETERS ABOVE. *** C *** FOR THE SPECIFIC FREE-FORMAT READ STATEMENTS, SEE THE MAIN *** C *** BODY OF THE CODE. *** C C C *** MULTINOMIAL PROBIT MODEL PARAMETERS *** C (PARAMETERS SPECIFIC TO THIS MODEL IMPLEMENTATION) C INTEGER ICOV, IDUM, ITASTE, NALT, NATTR INTEGER IUSER(18) EQUIVALENCE (UI(11),IUSER(1)) C C *** PARAMETER USAGE *** C C THE FOLLOWING ARE USER-PROVIDED INTEGER CONSTANTS: C C IDUM.... INDICATOR FOR ALTERNATIVE-SPECIFIC DUMMIES, C = 0 FOR NO, = 1 FOR YES. IF ICSET .NE. 0, THEN C THE SAME SET OF DUMMIES IS USED FOR EACH CHOICE SET. C OTHERWISE, INTEGER DATA SHOULD BE USED TO IDENTIFY THE C ALTERNATIVES IN EACH CHOICE SET (SEE NALT BELOW). C ICOV.... INDICATOR FOR TYPE OF ALTERNATIVE-SPECIFIC ERRORS, C = 0 FOR IID ERRORS, = 1 FOR CORRELATED ERRORS. C IF ICSET .NE. 0, THEN THE SAME CORRELATION MATRIX IS C USED FOR EVERY SUBSET. OTHERWISE, INTEGER DATA SHOULD C BE USED TO IDENTIFY THE ALTERNATIVES IN EACH CHOICE SET. C ITASTE.. INDICATOR FOR TASTE VARIATION, C = 0 FOR NO TASTE VARIATION, = 1 FOR UNCORRELATED TASTE C VARIATION, = 2 FOR CORRELATED TASTE VARIATION. C IUSER... INTEGER ARRAY THAT STORES MNP MODEL PARAMETERS USED IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C NALT.... TOTAL NUMBER OF NOMINAL CHOICE ALTERNATIVES (IF APPLICABLE). C IF ICSET .NE. 0, THEN NALT IS SET EQUAL TO ICSET. C OTHERWISE, NALT SHOULD BE > 0 IF EITHER IDUM OR ICOV C (OR BOTH) ARE > 0. C NATTR... NUMBER OF ATTRIBUTES (I.E., REAL DATA VARS.) PER C ALTERNATIVE. C C C *** READ STATEMENT FOR INPUT BLOCK 3 *** C C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER I, ICH, ICHECK, ICP, IETA0, IH, II, IICDAT, IICH, IIIV, 1 IIRV, IIU, INALT, IOBS, IPCOEF, IPCOV, IPDUM, IPRNT, 2 IPTAST, IRCDAT, IRU, IRW, ISCALE, ISIGP, ISIGU, ITST, 3 IV85, IV86, IV87, IV90, K, LCOVP, LCOVU, LCOVX, LOO, 4 LRI1, LRR1, LW, NBSCHK, NF, NPCHK, NPS, 5 NRICHK, NRRCHK, RDR DOUBLE PRECISION MKTSHR(20) DOUBLE PRECISION RFI, RHOSQR, RSQHAT, RLL0, RLLC, RLLR, RNI, 1 RNOBS C DOUBLE PRECISION ETA0, ONE, SCALE, TWO, ZERO C DATA ZERO/0.D0/ DATA ONE/1.D0/ DATA TWO/2.D0/ C C *** GENERAL *** C C CODED BY DAVID S. BUNCH C SUPPORTED BY U.S. DEPARTMENT OF TRANSPORTATION THROUGH C REGION NINE TRANSPORTATION CENTER AT UNIVERSITY OF CALIFORNIA, C BERKELEY (WINTER-SUMMER 1991) C--------------------------------- BODY ------------------------------ C C *** INITIALIZE SOME PARAMETERS *** C (SEE DISCUSSION ABOVE) NFIX = 0 LIV = 300 LRI1 = 24001 LRHOI = 28000 LRHOR = 164000 LRR1 = 160001 LV = 268105 LUI = 24000 LUR = 160000 LX = 60 C C *** READ MLEPCM PARAMETERS FROM INPUT BLOCK 1 *** C OPEN(1,FILE='fort.1') REWIND 1 OPEN(2,FILE='fort.2') REWIND 2 READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT, 1 COVTYP,IDR C IF (IOUNIT.LE.0) THEN IOUNIT = 6 WRITE(IOUNIT,10) 10 FORMAT(/' *** INVALID IOUNIT SET EQUAL TO 6 ***',//) ENDIF C WRITE(IOUNIT,20) 20 FORMAT(' PROGRAM MLMNP',//,' MAXIMUM LIKELIHOOD ESTIMATION OF', 1 /,' LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS',/, 1 ' (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED)',//) WRITE(IOUNIT,30) NOBS 30 FORMAT(' NUMBER OF OBSERVATIONS.................',I4) IF (ICSET.EQ.1) ICSET = 0 IF (ICSET.EQ.0) THEN WRITE(IOUNIT,40) 40 FORMAT(' FLEXIBLE CHOICE SETS USED') ELSE WRITE(IOUNIT,50) ICSET 50 FORMAT(' NUMBER OF ALTERNATIVES PER CHOICE SET..',I4) ENDIF IF (WEIGHT.EQ.1) THEN WRITE(IOUNIT,60) 60 FORMAT(' USER-PROVIDED WEIGHTS USED') ELSE WRITE(IOUNIT,70) 70 FORMAT(' EQUAL WEIGHTS FOR ALL OBSERVATIONS') ENDIF IF (NIVAR.EQ.-1) THEN WRITE(IOUNIT,80) 80 FORMAT(' NO INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.EQ.0) THEN WRITE(IOUNIT,90) 90 FORMAT(' FLEXIBLE INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.GT.0) THEN WRITE(IOUNIT,100) NIVAR 100 FORMAT(' NUMBER OF INTEGER DATA VALUES PER OBS..',I4) ENDIF IF (NRVAR.EQ.-1) THEN WRITE(IOUNIT,110) 110 FORMAT(' NO REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.EQ.0) THEN WRITE(IOUNIT,120) 120 FORMAT(' FLEXIBLE REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.GT.0) THEN WRITE(IOUNIT,130) NRVAR 130 FORMAT(' NUMBER OF REAL DATA VALUES PER OBS.....',I4) ENDIF WRITE(IOUNIT,140) IOUNIT 140 FORMAT(' OUTPUT UNIT............................',I4,/) IF ((COVTYP.NE.1).AND.(COVTYP.NE.2)) THEN COVTYP = 1 WRITE(IOUNIT,150) 150 FORMAT(' *** INVALID COVTYP SET TO 1 ***',/) ENDIF IF (COVTYP.EQ.1) WRITE(IOUNIT,160) 160 FORMAT(' COVARIANCE TYPE = INVERSE FINITE-DIFFERENCE HESSIAN') IF (COVTYP.EQ.2) WRITE(IOUNIT,170) 170 FORMAT(' COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN') IF ((IDR.LT.0).OR.(IDR.GT.3)) THEN IDR = 0 WRITE(IOUNIT,180) 180 FORMAT(/,' *** INVALID IDR SET TO 0 ***',/) ENDIF IF (IDR.EQ.0) WRITE(IOUNIT,190) 190 FORMAT(' NO REGRESSION DIAGNOSTICS REQUESTED') IF (IDR.GE.1) WRITE(IOUNIT,200) 200 FORMAT(' REGRESSION DIAGNOSTICS REQUESTED') IF ((IDR.EQ.1).OR.(IDR.EQ.2)) WRITE(IOUNIT,210) 210 FORMAT(' STANDARD LEAVE-ONE-OUT DIAGNOSTICS REQUESTED') IF (IDR.EQ.2) WRITE(IOUNIT,220) 220 FORMAT(' DIAGNOSTICS ON X-VECTOR REQUESTED') IF (IDR.EQ.3) WRITE(IOUNIT,230) 230 FORMAT(/,' *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED ***') WRITE(IOUNIT,*) C C *** PROCESS REGRESSION DIAGNOSTICS *** C IF (IDR.EQ.0) RDR = 0 C IF (IDR.EQ.1) THEN RDR = 1 LOO = 0 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = 0 IV90 = 0 NRICHK = LUI + 1 NRRCHK = 0 ENDIF C IF (IDR.EQ.2) THEN RDR = 2 LOO = 1 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = NOBS IV90 = LRR1 NRICHK = LUI + NOBS NRRCHK = LUR + NOBS * NPAR ENDIF C C *** INPUT FOR SPECIAL REGRESSION DIAGNOSTICS *** C *** BEGIN READING "INPUT BLOCK 2" *** C IF (IDR.EQ.3) THEN READ(1,*) BS, NB, XNOTI C IF (BS.LT.0) THEN BS = 0 WRITE(IOUNIT,240) 240 FORMAT(/,' *** NEGATIVE BLOCK-SIZE (BS) SET TO 0 ***',/) ENDIF C IF (NB.LE.0) THEN WRITE(IOUNIT,250) 250 FORMAT(/,' *** INVALID NO. OF BLOCKS (NB). STOP. ***',/) STOP ENDIF C IF ((XNOTI.NE.0).AND.(XNOTI.NE.1)) THEN XNOTI = 0 WRITE(IOUNIT,260) 260 FORMAT(/,' *** INVALID XNOTI SET TO 0. ***',/) ENDIF IF (XNOTI.EQ.1) WRITE(IOUNIT,220) WRITE(IOUNIT,270) NB 270 FORMAT(' NUMBER OF BLOCKS: ',I4) C RDR = 2 LOO = 2 IV85 = LRI1 IV86 = 0 IV87 = NB IF (XNOTI.EQ.1) THEN IV90 = LRR1 NRRCHK = LUR + NB * NPAR ENDIF C IF (BS.GT.0) THEN WRITE(IOUNIT,280) BS 280 FORMAT(' FIXED BLOCK SIZE: ',I4,/) IF (BS*NB.NE.NOBS) THEN WRITE(IOUNIT,290) 290 FORMAT(/,' *** (BS * NB) .NE. NOBS. STOP. ***',/) STOP ENDIF RHOI(LRI1) = BS NRICHK = LUI + 1 ELSE IV86 = 1 WRITE(IOUNIT,300) 300 FORMAT(' VARIABLE BLOCK-SIZE OPTION CHOSEN',/) NRICHK = LUI + NB ENDIF ENDIF C C *** CHECK SIZE OF RHOI *** IF (NRICHK.GT.LRHOI) THEN WRITE(IOUNIT,310) 310 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C *** IF VARIABLE-LENGTH BLOCKSIZES ARE USED, *** C *** READ THEM IN AND TEST THEM. *** C IF (IV86.EQ.1) THEN READ(1,*) (RHOI(I),I=LRI1,NRICHK) WRITE(IOUNIT,320) 320 FORMAT(' BLOCK-SIZES: ') WRITE(IOUNIT,330) (RHOI(I),I=LRI1,NRICHK) 330 FORMAT(5X,15I5) WRITE(IOUNIT,*) ICHECK = 0 DO 350 I = LRI1, NRICHK IF (RHOI(I).LE.0) THEN ICHECK = 1 WRITE(IOUNIT,340) I-LUI 340 FORMAT(' *** BLOCK-SIZE ',I5,' IS INVALID ***') ENDIF NBSCHK = NBSCHK + RHOI(I) 350 CONTINUE IF (ICHECK.EQ.1) THEN WRITE(IOUNIT,360) 360 FORMAT(/,' *** CANNOT PROCEED WITH INVALID BLOCK-SIZES. ', 1 'STOP. ***') STOP ENDIF IF (NBSCHK.NE.NOBS) THEN WRITE(IOUNIT,370) 370 FORMAT(/,' *** SUM OF BLOCK-SIZES .NE. NOBS. STOP. ***') STOP ENDIF ENDIF C C *** CHECK SIZE OF RHOR *** IF (NRRCHK.GT.LRHOR) THEN WRITE(IOUNIT,380) 380 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C C *** READ MNP PARAMETERS FROM INPUT BLOCK 3 *** C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C IF (ICSET.NE.0) THEN IF ((NALT.NE.0).AND.(NALT.NE.ICSET)) THEN WRITE(IOUNIT,390) 390 FORMAT(' *** NOTE: ERROR IN NALT OR ICSET ***') STOP ENDIF NALT = ICSET WRITE(IOUNIT,400) 400 FORMAT(' *** NOTE: NALT SET EQUAL TO ICSET ***') ENDIF IF (NALT.EQ.0) THEN WRITE(IOUNIT,410) 410 FORMAT(' NO NOMINAL VARIABLES') ELSE WRITE(IOUNIT,420) NALT 420 FORMAT(' NUMBER OF NOMINAL VARIABLES............',I4) ENDIF C WRITE(IOUNIT,430) NATTR 430 FORMAT(' NUMBER OF ATTRIBUTES PER ALTERNATIVE...',I4) IF (IDUM.EQ.0) THEN WRITE(IOUNIT,440) 440 FORMAT(' NO NOMINAL DUMMIES') ELSE WRITE(IOUNIT,450) 450 FORMAT(' NOMINAL DUMMIES USED') ENDIF IF (ICOV.EQ.0) THEN WRITE(IOUNIT,460) 460 FORMAT(' IID ERROR TERMS') ELSE WRITE(IOUNIT,470) 470 FORMAT(' CORRELATED ERROR TERMS') ENDIF IF (ITASTE.EQ.0) THEN WRITE(IOUNIT,480) 480 FORMAT(' NO RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.1) THEN WRITE(IOUNIT,490) 490 FORMAT(' UNCORRELATED RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.2) THEN WRITE(IOUNIT,500) 500 FORMAT(' CORRELATED RANDOM TASTE VARIATION') ENDIF C WRITE(IOUNIT,510) NPAR 510 FORMAT(/,' NUMBER OF MODEL PARAMETERS.............',I4,/) C C *** CHECK INITIAL DATA *** C (ADD MORE ERROR CHECKING HERE?) C IF (((IDUM.NE.0).OR.(ICOV.NE.0)).AND.(NALT.EQ.0)) THEN WRITE(IOUNIT,520) 520 FORMAT(' *** ERROR WITH IDUM OR ICOV OR NALT OR ICSET ***') STOP ENDIF C C *** CHECK NPAR *** C NPCHK = NATTR IF (IDUM.EQ.1) NPCHK = NPCHK + NALT - 1 LCOVX = 0 LCOVP = 0 LCOVU = 0 IF (ICOV.EQ.1) THEN LCOVX = NALT*(NALT-1)/2 - 1 NPCHK = NPCHK + LCOVX LCOVP = NALT*(NALT+1)/2 LCOVU = NALT*NALT ENDIF IF (ITASTE.EQ.1) NPCHK = NPCHK + NATTR IF (ITASTE.EQ.2) NPCHK = NPCHK + NATTR*(NATTR+1)/2 IF (NPAR.NE.NPCHK) THEN WRITE(IOUNIT,*) ' NPCHK = ',NPCHK WRITE(IOUNIT,*) ' INCORRECT NUMBER OF MODEL PARAMETERS' STOP ENDIF C C *** READ INITIAL PARAMETER ESTIMATES FROM UNIT 1 *** C WRITE(IOUNIT,530) 530 FORMAT(' INITIAL PARAMETER VECTOR AND BOUNDS: ') DO 560 I = 1, NPAR READ(1,540) VNAME(I) 540 FORMAT(1X,A8) READ(1,*) X(I), B(1,I), B(2,I) WRITE(IOUNIT,550) I, VNAME(I),X(I), B(1,I), B(2,I) 550 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) 560 CONTINUE CLOSE(1) C C *** SET UP UI STORAGE POINTERS (FOR MLEPCM) *** C C NIUSER AND NRUSER ARE USED TO RESERVE STORAGE FOR THE USER. C NIUSER AND NRUSER FOR MNP APPLICATION: C NIUSER = 18 LW = MAX(NATTR * NALT, LCOVP) NRUSER = LW + LCOVU + 2 C C (SEE HOW UI AND UR ARE USED BELOW TO PASS MNP INFORMATION) C C MLEPCM ARRAY POINTERS FOR UI: IIU = 11 IICH = NIUSER + IIU INALT = IICH + NOBS IIIV = INALT + NOBS IIRV = IIIV + NOBS IICDAT = IIRV + NOBS C C MLEPCM ARRAY POINTERS FOR UR: IRU = 1 ICP = IRU + NRUSER IRW = ICP + 2*NOBS IRCDAT = IRW + NOBS C C MLEPCM STORES POINTERS IN UI(1) THROUGH UI(10): UI(1) = IIU UI(2) = IICH UI(3) = INALT UI(4) = IIIV UI(5) = IIRV UI(6) = IICDAT UI(7) = IRU UI(8) = ICP UI(9) = IRW UI(10) = IRCDAT C C *** STORE MNP MODEL CONSTANTS STARTING IN IUSER(1) (=UI(11)) *** C C STORAGE FOR PASSING INVOCATION COUNTS: C UI(11) = NF1 = IUSER(1) C UI(12) = NF2 = IUSER(2) C C BASIC MNP MODEL INFORMATION: IUSER(3) = IOUNIT IUSER(4) = WEIGHT IUSER(5) = ICSET IUSER(6) = NALT IUSER(7) = NATTR IUSER(8) = IDUM IUSER(9) = ICOV IUSER(10) = ITASTE C C X ARRAY POINTERS (POINT TO START POSITION - 1): II = 0 IF (NATTR.NE.0) THEN IPCOEF = II II = II + NATTR ENDIF IF (IDUM.NE.0) THEN IPDUM = II II = II + NALT - 1 ENDIF IF (ICOV.NE.0) THEN IPCOV = II II = II + LCOVX ENDIF IF (ITASTE.NE.0) IPTAST = II C IUSER(11) = IPCOEF IUSER(12) = IPDUM IUSER(13) = IPCOV IUSER(14) = IPTAST C C ETA0 POINTER: IETA0 = 1 IUSER(17) = IETA0 C C SCALE POINTER: ISCALE = 2 IUSER(18) = ISCALE C C SIGMA (AND W) POINTERS: ISIGP = 3 C IW = ISIGP (W AND SIGP SHARE THE SAME STORAGE) ISIGU = ISIGP + LW C IUSER(15) = ISIGP IUSER(16) = ISIGU C C *** SET UP RUSER INFORMATION FOR MNP MODEL USE *** C C SET ETA0 EQUAL TO MACHEP C (ETA0 IS USED BY FINITE-DIFFERENCE ROUTINE DS7GRD.) ETA0 = DR7MDC(3) UR(IETA0) = ETA0 C C (SCALE SETS THE SCALING OF THE PROBIT MODEL COVARIANCE MATRIX) SCALE = ONE UR(ISCALE) = SCALE C C *** READ THE REST OF THE DATA FROM UNIT 1 (GENERAL TO MLEPCM ) *** C *** STORE IT IN THE APPROPRIATE UI AND UR LOCATIONS *** C IICDAT = IICDAT - 1 IRCDAT = IRCDAT - 1 DO 640 IOBS = 1, NOBS IF (ICSET.EQ.0) THEN READ(2,*) UI(IICH), UI(INALT) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH 570 FORMAT(1X,' CHOICE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE INDEX: ',/,5X,I3) WRITE(IOUNIT,580) 580 FORMAT(' *** PROGRAM TERMINATED... ***') STOP ENDIF ITST = UI(INALT) IF ((ITST.LE.1).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,590) IOBS,ITST 590 FORMAT(1X,' CHOICE SET SIZE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE SET SIZE: ',/,5X,I3) WRITE(IOUNIT,580) STOP ENDIF ELSE READ(2,*) UI(IICH) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH WRITE(IOUNIT,580) STOP ENDIF UI(INALT) = ICSET ENDIF C IF (NIVAR.EQ.0) THEN READ(2,*) UI(IIIV), (UI(IICDAT+K),K=1,UI(IIIV)) ENDIF IF (NIVAR.GT.0) THEN READ(2,*) (UI(IICDAT+K),K=1,NIVAR) UI(IIIV) = NIVAR ENDIF C C *** MNP CODE: CHECK INTEGER VALUES FOR CORRECTNESS *** C IF (NIVAR.GE.0) THEN DO 610 I = 1, UI(IIIV) ITST = UI(IICDAT+I) IF ((ITST.LE.0).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,600) IOBS,(UI(IICDAT+K),K=1,UI(IIIV)) 600 FORMAT(1X,' CHOICE SET INDEX ERROR IN OBS. NO. ', 1 I4,/,1X,' INTEGER VALUES: ',/,5X,20I3) WRITE(IOUNIT,580) STOP ENDIF 610 CONTINUE IICDAT = IICDAT + UI(IIIV) ENDIF C IF (IICDAT.GT.LUI) THEN WRITE(IOUNIT,620) 620 FORMAT(/,' *** STORAGE CAPACITY OF UI EXCEEDED ***') STOP ENDIF C IF (WEIGHT.EQ.1) THEN READ(2,*) UR(IRW) ELSE UR(IRW) = ONE ENDIF IF (ICSET.GT.1) MKTSHR(ICH) = MKTSHR(ICH) + UR(IRW) RLL0 = RLL0 + UR(IRW)*LOG(DBLE(UI(INALT))) C IF (NRVAR.EQ.0) THEN READ(2,*) UI(IIRV), (UR(IRCDAT+K),K=1,UI(IIRV)) IRCDAT = IRCDAT + UI(IIRV) ENDIF IF (NRVAR.GT.0) THEN READ(2,*) (UR(IRCDAT+K),K=1,NRVAR) UI(IIRV) = NRVAR IRCDAT = IRCDAT + NRVAR ENDIF IF (IRCDAT.GT.LUR) THEN WRITE(IOUNIT,630) 630 FORMAT(/,' *** STORAGE CAPACITY OF UR EXCEEDED ***') STOP ENDIF IICH = IICH + 1 INALT = INALT + 1 IIIV = IIIV + 1 IIRV = IIRV + 1 IRW = IRW + 1 640 CONTINUE CLOSE(2) C CALL DIVSET(1, IV, LIV, LV, V) C C *** SET REGRESSION DIAGNOSTIC CONSTANTS IV(83) = NFIX IV(84) = LOO IV(85) = IV85 IV(86) = IV86 IV(87) = IV87 IV(88) = 0 IV(89) = 0 IV(90) = IV90 C C IV(RDREQ) = 1 + 2*RDR IV(57) = 1 + 2*RDR C C IV(COVPRT) = 3 IV(14) = 5 C C SET IV(COVREQ) IF (COVTYP.EQ.1) IV(15) = -2 IF (COVTYP.EQ.2) IV(15) = 3 C C-------------------------------------------------------------------- C THE FOLLOWING COMMENTED-OUT CODE COULD BE USED TO ALTER C CONVERGENCE TOLERANCES: C (EXAMPLE: CALCULATE TOLERANCES AS THOUGH MACHEP WERE THE C SQUARE ROOT OF THE ACTUAL MACHEP) C MACHEP = SQRT(ETA0) C MEPCRT = MACHEP *** (ONE/THREE) C V(RFCTOL) = MAX(1.D-10, MEPCRT**2) C V(SCTOL) = V(RFCTOL) C V(XCTOL) = SQRT(MACHEP) C C WRITE(IOUNIT,650) V(RFCTOL), V(XCTOL) C650 FORMAT(//,' Relative F-Convergence tolerance: ',d13.6,/, C 1 ' Relative X-Convergence tolerance: ',d13.6,//) C-------------------------------------------------------------------- C IF (IV(1).NE.12) THEN WRITE(IOUNIT,*) ' There was a problem with calling DIVSET' STOP ENDIF C C *** SET MODE TO FIXED, UNIT SCALING IN OPTIMIZATION *** C *** IV(DYTYPE) = IV(16) = 0. V(DINIT) = V(38) = 1. *** IV(16) = 0 V(38) = ONE C *** THERE ARE NO "NUISANCE PARAMETERS" IN THIS IMPLEMENTATION *** NPS = NPAR C C *** ALLOCATE STORAGE AND OPTIMIZE C CALL DGLG(NOBS, NPAR, NPS, X, PCMRHO, RHOI, RHOR, IV, LIV, LV, V, 1 PCMRJ, UI, UR, MECDF) C-------------------------------------------------------------------- C *** COMPUTE ASYMPTOTIC T-STATISTICS *** C IH = ABS(IV(26)) - 1 IF (IH.GT.0) THEN DO 660 I = 1, NPAR IH = IH + I STDERR(I) = SQRT(V(IH)) IF (STDERR(I).GT.0) THEN TSTAT(I) = X(I)/STDERR(I) ELSE STDERR(I) = ZERO TSTAT(I) = ZERO ENDIF 660 CONTINUE C WRITE(IOUNIT,670) 670 FORMAT(/,' ASYMPTOTIC T-STATISTICS: ',/, 1 2X,'I',16X,'X(I)'11X,'T-STAT(I)', 2 7X,'STD ERROR') C DO 690 I = 1, NPAR WRITE(IOUNIT,680) I, VNAME(I), X(I), TSTAT(I), STDERR(I) 680 FORMAT(1X,I2,2X,A8,2X,E13.6,2(3X,E13.6)) 690 CONTINUE ENDIF C RLLR = TWO*(RLL0 - V(10)) WRITE(IOUNIT,700) NOBS, -V(10), -RLL0, RLLR 700 FORMAT(/,' NUMBER OF OBSERVATIONS (NOBS) = ',I4,//, 1 ' LOG-LIKELIHOOD L(EST) = ',E13.6,/, 1 ' LOG-LIKELIHOOD L(0) = ',E13.6,/, 1 ' -2[L(0) - L(EST)]: = ',E13.6,/) C IF (WEIGHT.EQ.0) THEN RHOSQR = ONE - V(10)/RLL0 RSQHAT = ONE - (V(10)+NPAR)/RLL0 WRITE(IOUNIT,710) RHOSQR, RSQHAT 710 FORMAT(' 1 - L(EST)/L(0): = ',E13.6,/, 1 ' 1 - (L(EST)-NPAR)/L(0) = ',E13.6,/) ELSE WRITE(IOUNIT, 720) 720 FORMAT(' WEIGHTS USED: RHO-SQUARES NOT REPORTED.',/) ENDIF IF (ICSET.GT.1) THEN WRITE(IOUNIT,730) 730 FORMAT(' (FIXED CHOICE SET SIZE)',//, 1 ' AGGREGATE CHOICES AND MARKET SHARES: ') IF (WEIGHT.EQ.1) WRITE(IOUNIT,740) 740 FORMAT(' (WEIGHTED)') RLLC = ZERO RNOBS = NOBS DO 760 I = 1, ICSET RNI = MKTSHR(I) RFI = RNI/RNOBS IF (RFI.GT.ZERO) RLLC = RLLC + RNI*LOG(RFI) WRITE(IOUNIT,750) I, MKTSHR(I), RFI 750 FORMAT(1X,I3,2X,F10.3,2X,F6.4) 760 CONTINUE RLLR = TWO * (-RLLC - V(10)) WRITE(IOUNIT, 770) RLLC, RLLR 770 FORMAT(/,' STATISTICS FOR CONSTANTS-ONLY MODEL:',/, 1 ' LOG-LIKELIHOOD L(C) = ',E13.6,/, 1 ' -2[L(C) - L(EST)]: = ',E13.6,/) ENDIF C IF (IPRNT.EQ.1) 1 CALL FPRINT(NOBS, NPAR, X, NF, UI, UR, MECDF) C WRITE(IOUNIT,780) 780 FORMAT(//,' OUTPUT FOR CONVENIENT RESTART:') DO 800 I = 1, NPAR WRITE(IOUNIT,540) VNAME(I) WRITE(IOUNIT,790) X(I), B(1,I), B(2,I) 790 FORMAT(1X,3(1X,E13.6)) 800 CONTINUE C *** LAST LINE OF MLMNP FOLLOWS *** END //GO.SYSIN DD mlmnp.f cat >mlmnpb.f <<'//GO.SYSIN DD mlmnpb.f' PROGRAM MLMNPB C C VERSION: SEPTEMBER 4, 1991 C C *** MAXIMUM LIKELIHOOD ESTIMATION OF THE LINEAR-IN-PARAMETERS *** C *** MULTINOMIAL PROBIT MODEL (VIA MENDELL-ELSTON PROBABILITIES). *** C *** SEE REFERENCES BELOW. *** C C *** THIS VERSION DOES IMPOSE SIMPLE BOUNDS ON THE PARAMETERS. *** C *** THIS VERSION DOES NOT CALCULATE T-SCORES AND REGRESSION *** C *** DIAGNOSTICS. *** C C *** THIS PROGRAM UTILIZES A GENERAL FRAMEWORK FOR MLE OF A *** C *** PROBABILISTIC CHOICE MODEL AND MAY BE MODIFIED FOR USE WITH *** C *** OTHER CHOICE MODELS. (SEE "PROTOTYE PROGRAM" DISCUSSION.) *** C C PROGRAM MLEPCM ("PROTOTYPE PROGRAM") C *** MAXIMUM LIKELIHOOD ESTIMATION OF PROBABILISTIC CHOICE MODELS *** C C *** DESCRIPTION *** C C THIS PROGRAM PERFORMS MAXIMUM LIKELIHOOD ESTIMATION BY MINIMIZING C THE NEGATIVE OF THE LOG-LIKELIHOOD FUNCTION. THE FUNCTION IS WRITTEN C AS C C -SUM{FOR I=1, NOBS} WT(I)*LOG P[ICH(I), IX(I), RX(I)] C C WHERE: C P[ICH(I), IX(I), RX(I)] IS A GENERAL PROBABILISTIC CHOICE MODEL, C ICH(I) IS THE CHOICE MADE FOR OBSERVATION I, C IX(I) CONTAINS INTEGER EXPLANATORY DATA SPECIFIC TO OBSERVATION I C (E.G., A LIST OF ALTERNATIVES IN THE CHOICE SET), C RX(I) CONTAINS REAL EXPLANATORY DATA SPECIFIC TO OBSERVATION I, C AND WT(I) IS A WEIGHT FOR OBSERVATION I. C C THIS PROGRAM IS DESIGNED TO CALL THE GENERALIZED REGRESSION C OPTIMIZATION SUBROUTINES DGLG AND DGLGB, WHICH IN TURN CALL DRGLG C AND DRGLGB, ETC. A FEW LEVELS DOWN, THE PROBABILITY C P[ICH(I), IX(I), RX(I)] IS COMPUTED IN A USER-SUPPLIED SUBROUTINE C CALCPR, USING THE FOLLOWING CALL: C C CALL CALCPR(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, C 1 PROB, IUSER, RUSER, MNPCDF) C C FOR A DESCRIPTION OF PARAMETER USAGE, SEE THE SUBROUTINE. C C *** MLEPCM PARAMETER DECLARATIONS *** C C SCALARS: C INTEGER BS, COVTYP, ICSET, IDR, IOUNIT, NB, NFIX, NIUSER INTEGER NIVAR, NOBS, NPAR, NRUSER, NRVAR, WEIGHT, XNOTI C C ARRAYS: C INTEGER IV(300), RHOI(28000), UI(24000) DOUBLE PRECISION B(2,60), RHOR(164000), UR(160000), V(268105) DOUBLE PRECISION X(60) EQUIVALENCE (RHOI(1), UI(1)), (RHOR(1), UR(1)) CHARACTER*8 VNAME(60) C C LENGTHS OF ARRAYS: C INTEGER LIV, LRHOI, LRHOR, LUI, LUR, LV, LX C C INTEGER IV(LIV), RHOI(LRHOI), UI(LUI) C DOUBLE PRECISION B(2,LX), RHOR(LRHOR), UR(LUR), V(LV), X(LX) C C SUBROUTINES: C DOUBLE PRECISION DR7MDC EXTERNAL DGLGB, DIVSET, DR7MDC, FPRINT, MECDF, PCMRHO, PCMRJ C C *** MLEPCM PARAMETER USAGE *** C C (SEE EXPLANATIONS BELOW) C C SCALARS: C C BS...... BLOCK-SIZE, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS ARE C REQUESTED AND ALL BLOCKS ARE THE SAME SIZE (SEE BELOW). C COVTYP.. INDICATES TYPE OF VARIANCE-COVARIANCE MATRIX APPROXIMATION. C = 1 FOR H^-1, WHERE H IS THE FINITE-DIFFERENCE HESSIAN C AT THE SOLUTION. C = 2 FOR (J^T J)^-1, I.E., THE GAUSS-NEWTON HESSIAN C APPROXIMATION AT THE SOLUTION. C ICSET... INDICATOR OF FIXED- OR VARIABLE-SIZE CHOICE SETS. C IDR..... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C IOUNIT.. OUTPUT UNIT NUMBER FOR PRINTING ERROR MESSAGES. C = FORTRAN UNIT FOR IOUNIT > 0. DEFAULT = 6. C IPRNT... INDEX INDICATING PRINT OPTIONS. C = 0 FOR NO ADDITIONAL PRINTING. C = 1 FOR FINAL CHOICE PROBABILITIES. C (DEFAULT = 0.) C WEIGHT. INDICATOR FOR USER-PROVIDED WEIGHTS. C NB...... NUMBER OF BLOCKS, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS C ARE REQUESTED (SEE BELOW). C NFIX.... PARAMETER USED BY DRGLG. NFIX = 0. C NIVAR... NUMBER OF (INTEGER) DATA VARIABLES PER CHOICE SET. C NIUSER.. NUMBER OF (INTEGER) USER-SPECIFIED CONSTANTS. C NOBS.... NUMBER OF OBSERVATIONS. C NPAR.... NUMBER OF MODEL PARAMETERS (X COMPONENTS). C NRVAR... NUMBER OF (REAL) DATA VARIABLES PER CHOICE SET. C NRUSER.. NUMBER OF (REAL) USER-SPECIFIED CONSTANTS. C XNOTI... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C C ARRAYS AND ARRAY LENGTHS: C C B....... REAL ARRAY OF UPPER AND LOWER BOUNDS ON PARAMETER VALUES. C IV...... INTEGER VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C LIV..... LENGTH OF IV; MUST BE AT LEAST 90 + NPAR. CURRENT LIV = 300. C LV...... LENGTH OF LV; MUST BE AT LEAST C 105 + P*(3*P + 16) + 2*N + 4P + N*(P + 2), WHERE C P = NPAR AND N = NOBS. FOR P = 60 AND N = 4000, THIS C EXPRESSION GIVES 268105. CURRENT LV = 268105. C LRHOI... LENGTH OF RHOI. CURRENT LRHOI = LUI + 4000 = 28000. C LRHOR... LENGTH OF RHOR. CURRENT LRHOR = LUR + 4000 = 164000. C LUI..... LENGTH OF UI. CURRENT LUI = 24000. C LUR..... LENGHT OF UR. CURRENT LUR = 160000. C LX...... LENGTH OF PARAMETER VECTOR X. CURRENT LX = 30. C RHOI.... INTEGER VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO PASS BLOCK-SIZES IF LEAVE-BLOCK-OUT C REGRESSION DIAGNOSTICS WITH VARIABLE BLOCK-SIZES ARE C REQUESTED (SEE BELOW). (CURRENT PCMRHO MAKES USE OF C RHOI THROUGH EQUIVALENCE OF RHOI WITH UI.) C RHOR.... REAL VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO STORE X(I) VECTORS, IF SUCH REGRESSION C DIAGNOSTICS ARE REQUESTED (SEE BELOW). (CURRENT PCMRHO C MAKES USE OF RHOR THROUGH 2EQUIVALENCE OF RHOR WITH UR.) C UI...... INTEGER VALUE ARRAY FOR USER STORAGE (SEE BELOW). C UI(1) TO UI(10) STORE MLEPCM PARAMETERS FOR USE IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C UR...... REAL VALUE ARRAY FOR USER STORAGE (SEE BELOW). C V....... REAL VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C VNAME... ARRAY OF PARAMETER NAMES FOR X COMPONENTS BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED. C C SUBROUTINES: C C PCMRJ... SUBROUTINE THAT CALCULATES GENERALIZED RESIDUAL VECTOR, C AND THE JACOBIAN OF THE GENERALIZED RESIDUAL VECTOR. C SEE DISCUSSION OF "CALCRJ" IN DGLG. C PCMRHO.. SUBROUTINE THAT CALCULATES THE CRITERION FUNCTION, AND C ITS DERIVATIVES. SEE DISCUSSION OF "RHO" IN DRGLG. C MECDF... SUBROUTINE THAT CALCULATES THE MULTIVARIATE NORMAL CDF C USING THE FIXED-ORDER MENDELL-ELSTON APPROXIMATION. C PASSED WITHOUT CHANGE TO CALCPR. (COULD BE REPLACED C WITH ANOTHER CDF ROUTINE IF DESIRED.) C C C *** DISCUSSION FOR MLEPCM *** C C *** DATA INPUT STREAM *** C C *** GENERAL PARAMETERS ARE READ IN FIRST FROM "INPUT BLOCK 1": *** C C READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT,COVTYP,IDR C C THESE PARAMETERS ARE INTENDED TO GIVE A FLEXIBLE INPUT C FORMAT FOR CHOICE MODELS, WITH SOME SHORTCUTS FOR SIMPLE CASES. C SPECIFIC SETTINGS OF THE ABOVE PARAMETERS WILL PRODUCE DIFFERENCES C IN THE INPUT STREAM FORMAT. C C FOR ICSET = 0 (OR 1) A VARIABLE NUMBER OF ALTERNATIVES PER CHOICE C SET IS USED. THE USER MUST PROVIDE THIS NUMBER FOR EACH C OBSERVATION. C FOR ICSET > 1 EACH CHOICE SET IS ASSUMED TO INCLUDE ICSET C ALTERNATIVES. C C WEIGHT = 1 MEANS THAT EACH OBSERVATION REQUIRES A WEIGHT, WHICH C MUST BE PROVIDED BY THE USER. C WEIGHT = 0 MEANS THAT ALL OBSERVATIONS AUTOMATICALLY RECEIVE EQUAL C WEIGHT AND THEREFORE NO USER-SUPPLIED WEIGHTS ARE REQUIRED. C C FOR NIVAR = -1 NO INTEGER DATA VALUES ARE REQUIRED BY THE MODEL. C FOR NIVAR = 0 A VARIABLE NUMBER OF INTEGER DATA VALUES IS STORED C PER OBSERVATION. IN THIS CASE, THE USER MUST INCLUDE FOR EACH C OBSERVATION THE NUMBER OF INTEGER VALUES TO BE STORED FOLLOWED C BY THE INTEGER VALUES THEMSELVES. (THIS MIGHT BE USED IN C CONJUNCTION WITH ICSET=0 TO LIST NOMINAL VARIABLES FOR THE C CHOICE ALTERNATIVES IN THE CHOICE SET.) C FOR NIVAR > 0 EACH OBSERVATION IS ASSUMED TO INCLUDE NIVAR INTEGERS. C C FOR NRVAR THE USAGE IS ANALOGOUS TO NIVAR, ONLY FOR REAL DATA. C C NIUSER AND NRUSER ARE USED TO INDICATE THE NUMBER OF CONSTANTS C TO BE PASSED TO THE MODEL SUBROUTINES. THESE ARE MODEL SPECIFIC. C FOR SOME CODES NIUSER, NRUSER, AND PERHAPS THE CONSTANTS, MIGHT C BE SET IN THE MAIN PROGRAM AND NOT BY THE INPUT STREAM. C C FOR MORE DETAILS ON THIS, SEE THE ACTUAL CODE BELOW. C C IN ADDITION TO DATA STORAGE, MLEPCM PROVIDES A RATHER FLEXIBLE C CHOICE OF STATISTICAL ANALYSES. IN THE VERSION OF THE PROGRAM C WHICH ENFORCES BOUNDS, STATISTICS ARE NOT CALCULATED. HOWEVER, C FOR CONVENIENCE IT IS ASSUMED THAT THE SAME INPUT STREAM IS USED C FOR BOTH PROGRAMS. C C TO CALCULATE ASYMPTOTIC T-SCORES, A VARIANCE-COVARIANCE MATRIX C APPROXIMATION IS REQUIRED. SEE COVTYP ABOVE. C C TO PERFORM REGRESSION DIAGNOSTICS, THE FOLLOWING PARAMETERS C ARE USED: C C IDR = 0 IF NO REGRESSION DIAGNOSTICS ARE DESIRED. C C = 1 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)), WHERE X(I) C MINIMIZES F (THE NEGATIVE LOG-LIKELIHOOD) WITH C OBSERVATION I REMOVED, AND X* IS THE MLE FOR THE FULL C DATASET. ("LEAVE-ONE-OUT" DIAGNOSTICS.) C C = 2 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)) AS WHEN IDR = 1, C AND ALSO THE ONE-STEP ESTIMATES OF X(I), I = 1 TO NOBS. C C = 3 FOR "LEAVE-BLOCK-OUT" DIAGNOSTICS. (DISCUSSION FOLLOWS.) C C *** PARAMETERS RELATED TO "LEAVE-BLOCK-OUT" REGRESSION DIAGNOSTICS *** C *** READ NEXT FROM "INPUT BLOCK 2" (IF APPLICABLE). *** C C "LEAVE-BLOCK-OUT" DIAGNOSTICS C C IN THIS CASE, ONE OR MORE ADDITIONAL LINES OF DATA ARE C REQUIRED. IF IDR = 3, THE FOLLOWING STATEMENT IS EXECUTED: C C READ(1,*) BS, NB, XNOTI C C NB = NUMBER OF BLOCKS C C XNOTI = 0 IF NO X(I) DIAGNOSTICS ARE REQUESTED, C = 1 OTHERWISE. C C BS > 0 MEANS THAT FIXED BLOCK SIZES OF SIZE BS ARE USED. C IN THIS CASE NB * BS = NOBS, AND THE PROGRAM C PROCEEDS TO "INPUT BLOCK 3" FOR MNP INPUT PARAMETERS. C C BS = 0 MEANS THAT VARIABLE BLOCK SIZES ARE USED. C IN THIS CASE THE NEXT FORMAT STATEMENT READS C THE BLOCK SIZES INTO RHOI USING FREE FORMAT: C C LR1 = LUI + 1 C LR2 = LR1 + NB C READ(1,*) (RHOI(I),I=LR1,LR2) C C *** THE PROGRAM THEN PROCEEDS TO "INPUT BLOCK 3" TO READ MODEL-*** C *** RELATED PARAMETERS. SEE DISCUSSION FOR MNP MODEL BELOW. *** C C *** INPUT BLOCK 4 CONTAINS THE INITIAL GUESS FOR THE SEARCH. *** C *** IT INCLUDES VARIABLE NAMES, A STARTING GUESS, AND BOUNDS. *** C C DO 10 I = 1, NPAR C READ(1,3) VNAME(I) C 3 FORMAT(1X,A8) C READ(1,*) X(I), B(1,I), B(2,I) C WRITE(IOUNIT,4) I, VNAME(I),X(I), B(1,I), B(2,I) C 4 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) C 10 CONTINUE C CLOSE(1) C C *** FOR THE LINEAR-IN-PARAMETERS MNP MODEL, THE ORDERING OF *** C *** PARAMETERS IS AS FOLLOWS: *** C C 1. MEAN TASTE WEIGHTS FOR GENERIC ATTRIBUTES (NATTR OF THESE). C 2. ALTERNATIVE-SPECIFIC MEANS (NALT-1 OF THESE). C 3. COVARIANCE PARAMETERS FOR ALTERNATIVE-SPECIFIC ERRORS. C THERE ARE 2(NALT-1)(NALT)/2 - 1 OF THESE, IN THE FORM OF C CHOLESKY DECOMPOSITION, STORED ROW-WISE: C B21 B22 C B31 B32 B33 C B(J-1,1) B(J-1,2) ..........B(J-1,J-1) C WHERE B11 = SCALE IS ASSUMED. C SEE BUNCH(1991, TRANSP. RES. B, VOL. 1, PP. 1-12); NOTE C THE MISPRINT IN EQUATION (26). C (NOTE THAT PARAMETERS ARE READ IN ONE PARAMETER PER LINE.) C 4. COVARIANCE PARAMETERS FOR TASTE VARIATION. C NATTR VARIANCES IF ITASTE=1 (UNCORRELATED). C NATTR*(NATTR+1)/2 CHOLESKY PARAMETERS IF ITASTE=2 C (I.E., CORRELATED). C C *** UNIT 1 IS CLOSED, AND THE MODEL DATA IS READ FROM UNIT 2. *** C *** ITS FORMAT IS CONTROLLED BY THE GENERAL PARAMETERS ABOVE. *** C *** FOR THE SPECIFIC FREE-FORMAT READ STATEMENTS, SEE THE MAIN *** C *** BODY OF THE CODE. *** C C C *** MULTINOMIAL PROBIT MODEL PARAMETERS *** C (PARAMETERS SPECIFIC TO THIS MODEL IMPLEMENTATION) C INTEGER IDUM, ICOV, ITASTE, NALT, NATTR INTEGER IUSER(18) EQUIVALENCE (UI(11),IUSER(1)) C C *** PARAMETER USAGE *** C C THE FOLLOWING ARE USER-PROVIDED INTEGER CONSTANTS: C C IDUM.... INDICATOR FOR ALTERNATIVE-SPECIFIC DUMMIES, C = 0 FOR NO, = 1 FOR YES. IF ICSET .NE. 0, THEN C THE SAME SET OF DUMMIES IS USED FOR EACH CHOICE SET. C OTHERWISE, INTEGER DATA SHOULD BE USED TO IDENTIFY THE C ALTERNATIVES IN EACH CHOICE SET (SEE NALT BELOW). C ICOV.... INDICATOR FOR TYPE OF ALTERNATIVE-SPECIFIC ERRORS, C = 0 FOR IID ERRORS, = 1 FOR CORRELATED ERRORS. C IF ICSET .NE. 0, THEN THE SAME CORRELATION MATRIX IS C USED FOR EVERY SUBSET. OTHERWISE, INTEGER DATA SHOULD C BE USED TO IDENTIFY THE ALTERNATIVES IN EACH CHOICE SET. C ITASTE.. INDICATOR FOR TASTE VARIATION, C = 0 FOR NO TASTE VARIATION, = 1 FOR UNCORRELATED TASTE C VARIATION, = 2 FOR CORRELATED TASTE VARIATION. C IUSER... INTEGER ARRAY THAT STORES MNP MODEL PARAMETERS USED IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C NALT.... TOTAL NUMBER OF NOMINAL CHOICE ALTERNATIVES (IF APPLICABLE). C IF ICSET .NE. 0, THEN NALT IS SET EQUAL TO ICSET. C OTHERWISE, NALT SHOULD BE > 0 IF EITHER IDUM OR ICOV C (OR BOTH) ARE > 0. C NATTR... NUMBER OF ATTRIBUTES (I.E., REAL DATA VARS.) PER ALTERNATIVE. C C C *** READ STATEMENT FOR INPUT BLOCK 3 *** C C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER I, ICH, ICHECK, ICP, IETA0, II, IICDAT, IICH, IIIV, IIRV, 1 IIU, INALT, IOBS, IPCOEF, IPCOV, IPDUM, IPRNT, IPTAST, 2 IRCDAT, IRU, IRW, ISCALE, ISIGP, ISIGU, ITST, IV85, IV86, 3 IV87, IV90, K, LCOVP, LCOVU, LCOVX, LOO, LRI1, LRR1, 4 LW, NBSCHK, NF, NPCHK, NPS, NRICHK, NRRCHK, RDR DOUBLE PRECISION MKTSHR(20) DOUBLE PRECISION RFI, RHOSQR, RSQHAT, RLL0, RLLC, RLLR, RNI, 1 RNOBS, SCALE C DOUBLE PRECISION ETA0, MACHEP, MEPCRT, ONE, TWO, ZERO C DATA ZERO/0.D0/ DATA ONE/1.D0/ DATA TWO/2.D0/ C C *** GENERAL *** C C CODED BY DAVID S. BUNCH C SUPPORTED BY U.S. DEPARTMENT OF TRANSPORTATION THROUGH C REGION NINE TRANSPORTATION CENTER AT UNIVERSITY OF CALIFORNIA, C BERKELEY (WINTER-SUMMER 1991) C--------------------------------- BODY ------------------------------ C C *** INITIALIZE SOME PARAMETERS *** C (SEE DISCUSSION ABOVE) NFIX = 0 LIV = 300 LRI1 = 24001 LRHOI = 28000 LRHOR = 164000 LRR1 = 160001 LV = 268105 LUI = 24000 LUR = 160000 LX = 60 C C *** READ MLEPCM PARAMETERS FROM INPUT BLOCK 1 *** C OPEN(1,FILE='fort.1') REWIND 1 OPEN(2,FILE='fort.2') REWIND 2 READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT, 1 COVTYP,IDR C IF (IOUNIT.LE.0) THEN IOUNIT = 6 WRITE(IOUNIT,10) 10 FORMAT(/' *** INVALID IOUNIT SET EQUAL TO 6 ***',//) ENDIF C WRITE(IOUNIT,20) 20 FORMAT(' PROGRAM MLMNPB',//,' MAXIMUM LIKELIHOOD ESTIMATION OF', 1 /,' LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS',/, 1 ' (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED)',//) WRITE(IOUNIT,30) NOBS 30 FORMAT(' NUMBER OF OBSERVATIONS.................',I4) IF (ICSET.EQ.1) ICSET = 0 IF (ICSET.EQ.0) THEN WRITE(IOUNIT,40) 40 FORMAT(' FLEXIBLE CHOICE SETS USED') ELSE WRITE(IOUNIT,50) ICSET 50 FORMAT(' NUMBER OF ALTERNATIVES PER CHOICE SET..',I4) ENDIF IF (WEIGHT.EQ.1) THEN WRITE(IOUNIT,60) 60 FORMAT(' USER-PROVIDED WEIGHTS USED') ELSE WRITE(IOUNIT,70) 70 FORMAT(' EQUAL WEIGHTS FOR ALL OBSERVATIONS') ENDIF IF (NIVAR.EQ.-1) THEN WRITE(IOUNIT,80) 80 FORMAT(' NO INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.EQ.0) THEN WRITE(IOUNIT,90) 90 FORMAT(' FLEXIBLE INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.GT.0) THEN WRITE(IOUNIT,100) NIVAR 100 FORMAT(' NUMBER OF INTEGER DATA VALUES PER OBS..',I4) ENDIF IF (NRVAR.EQ.-1) THEN WRITE(IOUNIT,110) 110 FORMAT(' NO REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.EQ.0) THEN WRITE(IOUNIT,120) 120 FORMAT(' FLEXIBLE REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.GT.0) THEN WRITE(IOUNIT,130) NRVAR 130 FORMAT(' NUMBER OF REAL DATA VALUES PER OBS.....',I4) ENDIF WRITE(IOUNIT,140) IOUNIT 140 FORMAT(' OUTPUT UNIT............................',I4,/) IF ((COVTYP.NE.1).AND.(COVTYP.NE.2)) THEN COVTYP = 1 WRITE(IOUNIT,150) 150 FORMAT(' *** INVALID COVTYP SET TO 1 ***',/) ENDIF IF (COVTYP.EQ.1) WRITE(IOUNIT,160) 160 FORMAT(' COVARIANCE TYPE = INVERSE FINITE-DIFFERENCE HESSIAN') IF (COVTYP.EQ.2) WRITE(IOUNIT,170) 170 FORMAT(' COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN') IF ((IDR.LT.0).OR.(IDR.GT.3)) THEN IDR = 0 WRITE(IOUNIT,180) 180 FORMAT(/,' *** INVALID IDR SET TO 0 ***',/) ENDIF IF (IDR.EQ.0) WRITE(IOUNIT,190) 190 FORMAT(' NO REGRESSION DIAGNOSTICS REQUESTED') IF (IDR.GE.1) WRITE(IOUNIT,200) 200 FORMAT(' REGRESSION DIAGNOSTICS REQUESTED') IF ((IDR.EQ.1).OR.(IDR.EQ.2)) WRITE(IOUNIT,210) 210 FORMAT(' STANDARD LEAVE-ONE-OUT DIAGNOSTICS REQUESTED') IF (IDR.EQ.2) WRITE(IOUNIT,220) 220 FORMAT(' DIAGNOSTICS ON X-VECTOR REQUESTED') IF (IDR.EQ.3) WRITE(IOUNIT,230) 230 FORMAT(/,' *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED ***') WRITE(IOUNIT,*) C C *** PROCESS REGRESSION DIAGNOSTICS *** C IF (IDR.EQ.0) RDR = 0 C IF (IDR.EQ.1) THEN RDR = 1 LOO = 0 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = 0 IV90 = 0 NRICHK = LUI + 1 NRRCHK = 0 ENDIF C IF (IDR.EQ.2) THEN RDR = 2 LOO = 1 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = NOBS IV90 = LRR1 NRICHK = LUI + NOBS NRRCHK = LUR + NOBS * NPAR ENDIF C C *** INPUT FOR SPECIAL REGRESSION DIAGNOSTICS *** C *** BEGIN READING "INPUT BLOCK 2" *** C IF (IDR.EQ.3) THEN READ(1,*) BS, NB, XNOTI C IF (BS.LT.0) THEN BS = 0 WRITE(IOUNIT,240) 240 FORMAT(/,' *** NEGATIVE BLOCK-SIZE (BS) SET TO 0 ***',/) ENDIF C IF (NB.LE.0) THEN WRITE(IOUNIT,250) 250 FORMAT(/,' *** INVALID NO. OF BLOCKS (NB). STOP. ***',/) STOP ENDIF C IF ((XNOTI.NE.0).AND.(XNOTI.NE.1)) THEN XNOTI = 0 WRITE(IOUNIT,260) 260 FORMAT(/,' *** INVALID XNOTI SET TO 0. ***',/) ENDIF IF (XNOTI.EQ.1) WRITE(IOUNIT,220) WRITE(IOUNIT,270) NB 270 FORMAT(' NUMBER OF BLOCKS: ',I4) C RDR = 2 LOO = 2 IV85 = LRI1 IV86 = 0 IV87 = NB IF (XNOTI.EQ.1) THEN IV90 = LRR1 NRRCHK = LUR + NB * NPAR ENDIF C IF (BS.GT.0) THEN WRITE(IOUNIT,280) BS 280 FORMAT(' FIXED BLOCK SIZE: ',I4,/) IF (BS*NB.NE.NOBS) THEN WRITE(IOUNIT,290) 290 FORMAT(/,' *** (BS * NB) .NE. NOBS. STOP. ***',/) STOP ENDIF RHOI(LRI1) = BS NRICHK = LUI + 1 ELSE IV86 = 1 WRITE(IOUNIT,300) 300 FORMAT(' VARIABLE BLOCK-SIZE OPTION CHOSEN',/) NRICHK = LUI + NB ENDIF ENDIF C C *** CHECK SIZE OF RHOI *** IF (NRICHK.GT.LRHOI) THEN WRITE(IOUNIT,310) 310 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C *** IF VARIABLE-LENGTH BLOCKSIZES ARE USED, *** C *** READ THEM IN AND TEST THEM. *** IF (IV86.EQ.1) THEN READ(1,*) (RHOI(I),I=LRI1,NRICHK) WRITE(IOUNIT,320) 320 FORMAT(' BLOCK-SIZES: ') WRITE(IOUNIT,330) (RHOI(I),I=LRI1,NRICHK) 330 FORMAT(5X,15I5) WRITE(IOUNIT,*) ICHECK = 0 DO 350 I = LRI1, NRICHK IF (RHOI(I).LE.0) THEN ICHECK = 1 WRITE(IOUNIT,340) I-LUI 340 FORMAT(' *** BLOCK-SIZE ',I5,' IS INVALID ***') ENDIF NBSCHK = NBSCHK + RHOI(I) 350 CONTINUE IF (ICHECK.EQ.1) THEN WRITE(IOUNIT,360) 360 FORMAT(/,' *** CANNOT PROCEED WITH INVALID BLOCK-SIZES. ', 1 'STOP. ***') STOP ENDIF IF (NBSCHK.NE.NOBS) THEN WRITE(IOUNIT,370) 370 FORMAT(/,' *** SUM OF BLOCK-SIZES .NE. NOBS. STOP. ***') STOP ENDIF ENDIF C C *** CHECK SIZE OF RHOR *** IF (NRRCHK.GT.LRHOR) THEN WRITE(IOUNIT,380) 380 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C C *** READ MNP PARAMETERS FROM INPUT BLOCK 3 *** C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C IF (ICSET.NE.0) THEN IF ((NALT.NE.0).AND.(NALT.NE.ICSET)) THEN WRITE(IOUNIT,390) 390 FORMAT(' *** NOTE: ERROR IN NALT OR ICSET ***') STOP ENDIF NALT = ICSET WRITE(IOUNIT,400) 400 FORMAT(' *** NOTE: NALT SET EQUAL TO ICSET ***') ENDIF IF (NALT.EQ.0) THEN WRITE(IOUNIT,410) 410 FORMAT(' NO NOMINAL VARIABLES') ELSE WRITE(IOUNIT,420) NALT 420 FORMAT(' NUMBER OF NOMINAL VARIABLES............',I4) ENDIF C WRITE(IOUNIT,430) NATTR 430 FORMAT(' NUMBER OF ATTRIBUTES PER ALTERNATIVE...',I4) IF (IDUM.EQ.0) THEN WRITE(IOUNIT,440) 440 FORMAT(' NO NOMINAL DUMMIES') ELSE WRITE(IOUNIT,450) 450 FORMAT(' NOMINAL DUMMIES USED') ENDIF IF (ICOV.EQ.0) THEN WRITE(IOUNIT,460) 460 FORMAT(' IID ERROR TERMS') ELSE WRITE(IOUNIT,470) 470 FORMAT(' CORRELATED ERROR TERMS') ENDIF IF (ITASTE.EQ.0) THEN WRITE(IOUNIT,480) 480 FORMAT(' NO RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.1) THEN WRITE(IOUNIT,490) 490 FORMAT(' UNCORRELATED RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.2) THEN WRITE(IOUNIT,500) 500 FORMAT(' CORRELATED RANDOM TASTE VARIATION') ENDIF C WRITE(IOUNIT,510) NPAR 510 FORMAT(/,' NUMBER OF MODEL PARAMETERS.............',I4,/) C C *** CHECK INITIAL DATA *** C (ADD MORE ERROR CHECKING HERE?) C IF (((IDUM.NE.0).OR.(ICOV.NE.0)).AND.(NALT.EQ.0)) THEN WRITE(IOUNIT,520) 520 FORMAT(' *** ERROR WITH IDUM OR ICOV OR NALT OR ICSET ***') STOP ENDIF C C *** CHECK NPAR *** C NPCHK = NATTR IF (IDUM.EQ.1) NPCHK = NPCHK + NALT - 1 LCOVX = 0 LCOVP = 0 LCOVU = 0 IF (ICOV.EQ.1) THEN LCOVX = NALT*(NALT-1)/2 - 1 NPCHK = NPCHK + LCOVX LCOVP = NALT*(NALT+1)/2 LCOVU = NALT*NALT ENDIF IF (ITASTE.EQ.1) NPCHK = NPCHK + NATTR IF (ITASTE.EQ.2) NPCHK = NPCHK + NATTR*(NATTR+1)/2 IF (NPAR.NE.NPCHK) THEN WRITE(IOUNIT,*) ' NPCHK = ',NPCHK WRITE(IOUNIT,*) ' INCORRECT NUMBER OF MODEL PARAMETERS' STOP ENDIF C C *** READ INITIAL PARAMETER ESTIMATES FROM UNIT 1 *** C WRITE(IOUNIT,530) 530 FORMAT(' INITIAL PARAMETER VECTOR AND BOUNDS: ') DO 560 I = 1, NPAR READ(1,540) VNAME(I) 540 FORMAT(1X,A8) READ(1,*) X(I), B(1,I), B(2,I) WRITE(IOUNIT,550) I, VNAME(I),X(I), B(1,I), B(2,I) 550 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) 560 CONTINUE CLOSE(1) C C *** SET UP UI STORAGE POINTERS (FOR MLEPCM) *** C C NIUSER AND NRUSER ARE USED TO RESERVE STORAGE FOR THE USER. C NIUSER AND NRUSER FOR MNP APPLICATION: C NIUSER = 18 LW = MAX(NATTR * NALT, LCOVP) NRUSER = LW + LCOVU + 2 C C (SEE HOW UI AND UR ARE USED BELOW TO PASS MNP INFORMATION) C C MLEPCM ARRAY POINTERS FOR UI: IIU = 11 IICH = NIUSER + IIU INALT = IICH + NOBS IIIV = INALT + NOBS IIRV = IIIV + NOBS IICDAT = IIRV + NOBS C C MLEPCM ARRAY POINTERS FOR UR: IRU = 1 ICP = IRU + NRUSER IRW = ICP + 2*NOBS IRCDAT = IRW + NOBS C C MLEPCM STORES POINTERS IN UI(1) THROUGH UI(10): UI(1) = IIU UI(2) = IICH UI(3) = INALT UI(4) = IIIV UI(5) = IIRV UI(6) = IICDAT UI(7) = IRU UI(8) = ICP UI(9) = IRW UI(10) = IRCDAT C C *** STORE MNP MODEL CONSTANTS STARTING IN IUSER(1) (=UI(11)) *** C C STORAGE FOR PASSING INVOCATION COUNTS: C UI(11) = NF1 = IUSER(1) C UI(12) = NF2 = IUSER(2) C C BASIC MNP MODEL INFORMATION: IUSER(3) = IOUNIT IUSER(4) = WEIGHT IUSER(5) = ICSET IUSER(6) = NALT IUSER(7) = NATTR IUSER(8) = IDUM IUSER(9) = ICOV IUSER(10) = ITASTE C C X ARRAY POINTERS (POINT TO START POSITION - 1): II = 0 IF (NATTR.NE.0) THEN IPCOEF = II II = II + NATTR ENDIF IF (IDUM.NE.0) THEN IPDUM = II II = II + NALT - 1 ENDIF IF (ICOV.NE.0) THEN IPCOV = II II = II + LCOVX ENDIF IF (ITASTE.NE.0) IPTAST = II C IUSER(11) = IPCOEF IUSER(12) = IPDUM IUSER(13) = IPCOV IUSER(14) = IPTAST C C ETA0 POINTER: IETA0 = 1 IUSER(17) = IETA0 C C SCALE POINTER: ISCALE = 2 IUSER(18) = ISCALE C C SIGMA (AND W) POINTERS: ISIGP = 3 C IW = ISIGP (W AND SIGP SHARE THE SAME STORAGE) ISIGU = ISIGP + LW C IUSER(15) = ISIGP IUSER(16) = ISIGU C C *** SET UP RUSER INFORMATION FOR MNP MODEL USE *** C C SET ETA0 EQUAL TO MACHEP C (ETA0 IS USED BY FINITE-DIFFERENCE ROUTINE DS7GRD.) ETA0 = DR7MDC(3) UR(IETA0) = ETA0 C C (SCALE SETS THE SCALING OF THE PROBIT MODEL COVARIANCE MATRIX) SCALE = ONE UR(ISCALE) = SCALE C C *** READ THE REST OF THE DATA FROM UNIT 1 (GENERAL TO MLEPCM ) *** C *** STORE IT IN THE APPROPRIATE UI AND UR LOCATIONS *** C IICDAT = IICDAT - 1 IRCDAT = IRCDAT - 1 DO 640 IOBS = 1, NOBS IF (ICSET.EQ.0) THEN READ(2,*) UI(IICH), UI(INALT) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH 570 FORMAT(1X,' CHOICE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE INDEX: ',/,5X,I3) WRITE(IOUNIT,580) 580 FORMAT(' *** PROGRAM TERMINATED... ***') STOP ENDIF ITST = UI(INALT) IF ((ITST.LE.1).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,590) IOBS,ITST 590 FORMAT(1X,' CHOICE SET SIZE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE SET SIZE: ',/,5X,I3) WRITE(IOUNIT,580) STOP ENDIF ELSE READ(2,*) UI(IICH) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH WRITE(IOUNIT,580) STOP ENDIF UI(INALT) = ICSET ENDIF C IF (NIVAR.EQ.0) THEN READ(2,*) UI(IIIV), (UI(IICDAT+K),K=1,UI(IIIV)) ENDIF IF (NIVAR.GT.0) THEN READ(2,*) (UI(IICDAT+K),K=1,NIVAR) UI(IIIV) = NIVAR ENDIF C C *** MNP CODE: CHECK INTEGER VALUES FOR CORRECTNESS *** C IF (NIVAR.GE.0) THEN DO 610 I = 1, UI(IIIV) ITST = UI(IICDAT+I) IF ((ITST.LE.0).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,600) IOBS,(UI(IICDAT+K),K=1,UI(IIIV)) 600 FORMAT(1X,' CHOICE SET INDEX ERROR IN OBS. NO. ', 1 I4,/,1X,' INTEGER VALUES: ',/,5X,20I3) WRITE(IOUNIT,580) STOP ENDIF 610 CONTINUE IICDAT = IICDAT + UI(IIIV) ENDIF C IF (IICDAT.GT.LUI) THEN WRITE(IOUNIT,620) 620 FORMAT(/,' *** STORAGE CAPACITY OF UI EXCEEDED ***') STOP ENDIF C IF (WEIGHT.EQ.1) THEN READ(2,*) UR(IRW) ELSE UR(IRW) = ONE ENDIF IF (ICSET.GT.1) MKTSHR(ICH) = MKTSHR(ICH) + UR(IRW) RLL0 = RLL0 + UR(IRW)*LOG(DBLE(UI(INALT))) C IF (NRVAR.EQ.0) THEN READ(2,*) UI(IIRV), (UR(IRCDAT+K),K=1,UI(IIRV)) IRCDAT = IRCDAT + UI(IIRV) ENDIF IF (NRVAR.GT.0) THEN READ(2,*) (UR(IRCDAT+K),K=1,NRVAR) UI(IIRV) = NRVAR IRCDAT = IRCDAT + NRVAR ENDIF IF (IRCDAT.GT.LUR) THEN WRITE(IOUNIT,630) 630 FORMAT(/,' *** STORAGE CAPACITY OF UR EXCEEDED ***') STOP ENDIF IICH = IICH + 1 INALT = INALT + 1 IIIV = IIIV + 1 IIRV = IIRV + 1 IRW = IRW + 1 640 CONTINUE CLOSE(2) C CALL DIVSET(1, IV, LIV, LV, V) C C *** SET REGRESSION DIAGNOSTIC CONSTANTS IV(83) = NFIX IV(84) = LOO IV(85) = IV85 IV(86) = IV86 IV(87) = IV87 IV(88) = 0 IV(89) = 0 IV(90) = IV90 C C IV(RDREQ) = 1 + 2*RDR IV(57) = 1 + 2*RDR C C IV(COVPRT) = 3 IV(14) = 5 C C SET IV(COVREQ) IF (COVTYP.EQ.1) IV(15) = -2 IF (COVTYP.EQ.2) IV(15) = 3 C C-------------------------------------------------------------------- C THE FOLLOWING COMMENTED-OUT CODE COULD BE USED TO ALTER C CONVERGENCE TOLERANCES: C (EXAMPLE: CALCULATE TOLERANCES AS THOUGH MACHEP WERE THE C SQUARE ROOT OF THE ACTUAL MACHEP) C MACHEP = SQRT(ETA0) C MEPCRT = MACHEP *** (ONE/THREE) C V(RFCTOL) = MAX(1.D-10, MEPCRT**2) C V(SCTOL) = V(RFCTOL) C V(XCTOL) = SQRT(MACHEP) C C WRITE(IOUNIT,650) V(RFCTOL), V(XCTOL) C650 FORMAT(//,' Relative F-Convergence tolerance: ',E13.6,/, C 1 ' Relative X-Convergence tolerance: ',E13.6,//) C-------------------------------------------------------------------- C IF (IV(1).NE.12) THEN WRITE(IOUNIT,*) ' There was a problem with calling DIVSET' STOP ENDIF C C *** SET MODE TO FIXED, UNIT SCALING IN OPTIMIZATION *** C *** IV(DYTYPE) = IV(16) = 0. V(DINIT) = V(38) = 1. *** IV(16) = 0 V(38) = ONE C *** THERE ARE NO "NUISANCE PARAMETERS" IN THIS IMPLEMENTATION *** NPS = NPAR C C *** ALLOCATE STORAGE AND OPTIMIZE C CALL DGLGB(NOBS, NPAR, NPS, X, B, PCMRHO, RHOI, RHOR, IV, LIV, 1 LV, V, PCMRJ, UI, UR, MECDF) C-------------------------------------------------------------------- RLLR = TWO*(RLL0 - V(10)) WRITE(IOUNIT,660) NOBS, -V(10), -RLL0, RLLR 660 FORMAT(/,' NUMBER OF OBSERVATIONS (NOBS) = ',I4,//, 1 ' LOG-LIKELIHOOD L(EST) = ',E13.6,/, 1 ' LOG-LIKELIHOOD L(0) = ',E13.6,/, 1 ' -2[L(0) - L(EST)]: = ',E13.6,/) C IF (WEIGHT.EQ.0) THEN RHOSQR = ONE - V(10)/RLL0 RSQHAT = ONE - (V(10)+NPAR)/RLL0 WRITE(IOUNIT,670) RHOSQR, RSQHAT 670 FORMAT(' 1 - L(EST)/L(0): = ',E13.6,/, 1 ' 1 - (L(EST)-NPAR)/L(0) = ',E13.6,/) ELSE WRITE(IOUNIT, 680) 680 FORMAT(' WEIGHTS USED: RHO-SQUARES NOT REPORTED.',/) ENDIF IF (ICSET.GT.1) THEN WRITE(IOUNIT,690) 690 FORMAT(' (FIXED CHOICE SET SIZE)',//, 1 ' AGGREGATE CHOICES AND MARKET SHARES: ') IF (WEIGHT.EQ.1) WRITE(IOUNIT,700) 700 FORMAT(' (WEIGHTED)') RLLC = ZERO RNOBS = NOBS DO 720 I = 1, ICSET RNI = MKTSHR(I) RFI = RNI/RNOBS IF (RFI.GT.ZERO) RLLC = RLLC + RNI*LOG(RFI) WRITE(IOUNIT,710) I, MKTSHR(I), RFI 710 FORMAT(1X,I3,2X,F10.3,2X,F6.4) 720 CONTINUE RLLR = TWO * (-RLLC - V(10)) WRITE(IOUNIT, 730) RLLC, RLLR 730 FORMAT(/,' STATISTICS FOR CONSTANTS-ONLY MODEL:',/, 1 ' LOG-LIKELIHOOD L(C) = ',E13.6,/, 1 ' -2[L(C) - L(EST)]: = ',E13.6,/) ENDIF C IF (IPRNT.EQ.1) 1 CALL FPRINT(NOBS, NPAR, X, NF, UI, UR, MECDF) C WRITE(IOUNIT,740) 740 FORMAT(//,' OUTPUT FOR CONVENIENT RESTART:') DO 760 I = 1, NPAR WRITE(IOUNIT,540) VNAME(I) WRITE(IOUNIT,750) X(I), B(1,I), B(2,I) 750 FORMAT(1X,3(1X,E13.6)) 760 CONTINUE C *** LAST LINE OF MLMNP FOLLOWS *** END //GO.SYSIN DD mlmnpb.f cat >mnpsubs.f <<'//GO.SYSIN DD mnpsubs.f' SUBROUTINE CALCPR(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB, IUSER, RUSER, MNPCDF) C C *** THIS SUBROUTINE CALCULATES A PROBABILITY FOR THE MODEL AND *** C *** DATA GIVEN. FOR MULTINOMIAL PROBIT SOME ADDITIONAL STORAGE *** C *** CUSTOMIZATION IS REQUIRED. THIS APPROACH CAN BE *** C *** USED FOR OTHER CHOICE MODELS, WITH APPROPRIATE MODIFICATIONS *** C *** TO THE ARRAYS USED BELOW. *** C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER NPAR, IERR, ICH, IALT, II, ICDAT(*), IR, IUSER(*) DOUBLE PRECISION X(NPAR), RCDAT(*), PROB, RUSER(*) EXTERNAL MNPCDF C C *** CALCPR PARAMETER USAGE *** C C IALT.... NUMBER OF CHOICES AVAILABLE IN THE CHOICE SET. C ICDAT... VECTOR OF INTEGER DATA VALUES. C ICH..... INTEGER INDICATING THE CHOICE. 1 <= ICH <= IALT. C IERR.... INTEGER FOR PASSING ERROR INFORMATION. C IN THIS ROUTINE, IF IERR = 1 ON RETURN THEN THERE WERE C NO PROBLEMS. C IF IERR = 0 ON RETURN, THEN THE PROBABILITY COULD NOT C BE COMPUTED USING THE CURRENT PARAMETERS IN X. C II...... NUMBER OF INTEGER VALUES STORED IN VECTIR ICDAT. C IUSER... MODEL-RELATED INTEGER VALUES USED BY CALCPR. CONTAINS C ARRAY POINTERS TO MANAGE DATA STORAGE, AND OTHER C PARAMETERS. C MNPCDF.. SUBROUTINE WHICH CALCULATES THE CDF OF A MULTIVARIATE C NORMAL DISTRIBUTION. C NPAR.... NUMBER OF PARAMETERS IN VECTOR X. C PROB.... ON RETURN, CHOICE PROBABILITY COMPUTED USING PARAMETERS IN C X AND DATA IN ICDAT AND RCDAT. C RCDAT... VECTOR OF REAL DATA VALUES. C RUSER... MODEL-RELATED REAL VALUES USED BY CALCPR. CAN CONTAIN C USEFUL PARAMETERS, AND ALSO EXTRA WORK STORAGE. C EXTERNAL CALCP1 INTEGER ISIGU, IW, NALT, NW C ISIGU = IUSER(16) IW = IUSER(15) NALT = MAX(1,IUSER(6)) NW = MAX(1, IUSER(7)) CALL CALCP1(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB, IUSER, RUSER, NALT, RUSER(ISIGU), 2 NW, RUSER(IW), MNPCDF) C *** LAST LINE OF CALCPR FOLLOWS *** END SUBROUTINE CALCP1(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB, IUSER, RUSER, NALT, SIGU, NW, W, MNPCDF) C C *** THIS SUBROUTINE CALCULATES A PROBABILITY FOR THE MNP MODEL *** C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER NPAR, IERR, ICH, IALT, II, ICDAT(*), IR, IUSER(*), NALT, 1 NATTR, NW DOUBLE PRECISION X(NPAR), RCDAT(*), PROB, RUSER(*), 1 SIGU(NALT,NALT), W(NW,NALT) EXTERNAL MNPCDF C C *** CALCP1 PARAMETER USAGE *** C C IALT.... NUMBER OF CHOICES AVAILABLE IN THE CHOICE SET. C ICDAT... VECTOR OF INTEGER DATA VALUES. C IN THIS SUBROUTINE, ICDAT STORES INTEGER INDEXES WHICH C DEFINE WHICH OF THE NOMINAL ALTERNATIVES ARE AVAILABLE C IN THE CHOICE SET. (THIS IS FOR THE CASE WHEN THERE C ARE NALT NOMINAL CHOICE ALTERNATIVES, BUT NOT ALL OF C THEM NECESSARILY APPEAR IN EVERY SUBSET. IF ALL NALT C ALTERNATIVES APPEAR IN ALL SUBSETS, THEN ICSET = NALT >0 C SHOULD BE USED WITH IDUM = 1. C ICH..... INTEGER INDICATING THE CHOICE. 1 <= ICH <= IALT. C ICOV.... INDICATOR FOR TYPE OF ALTERNATIVE-SPECIFIC ERRORS, C = 0 FOR IID ERRORS, = 1 FOR CORRELATED ERRORS. C IF ICSET .NE. 0, THEN THE SAME CORRELATION MATRIX IS C USED FOR EVERY SUBSET. OTHERWISE, INTEGER DATA SHOULD C BE USED TO IDENTIFY THE ALTERNATIVES IN EACH CHOICE SET. C (STORED IN IUSER.) C IDUM... INDICATOR FOR ALTERNATIVE-SPECIFIC DUMMIES, C = 0 FOR NO, = 1 FOR YES. IF ICSET .NE. 0, THEN C THE SAME SET OF DUMMIES IS USED FOR EACH CHOICE SET. C OTHERWISE, INTEGER DATA SHOULD BE USED TO IDENTIFY THE C ALTERNATIVES IN EACH CHOICE SET (SEE NALT BELOW). C (STORED IN IUSER). C IERR.... INTEGER FOR PASSING ERROR INFORMATION. C IN THIS ROUTINE, IF IERR = 1 ON RETURN THEN THERE WERE C NO PROBLEMS. C IF IERR = 0 ON RETURN, THEN THE PROBABILITY COULD NOT C BE COMPUTED USING THE CURRENT PARAMETERS IN X. C II...... NUMBER OF INTEGER VALUES STORED IN VECTIR ICDAT. C IUSER... MODEL-RELATED INTEGER VALUES USED BY CALCPR. THE FIRST C PORTION OF IUSER CONTAINS SUCH THINGS AS ARRAY POINTERS. C IUSER ALSO CONTAINS STORED VALUES OF NATTR, IDUM, ETC. C IR...... NUMBER OF REAL VALUES STORED IN VECTOR IRDAT. C ITASTE.. INDICATOR FOR TASTE VARIATION, C = 0 FOR NO TASTE VARIATION, = 1 FOR UNCORRELATED TASTE C VARIATION, = 2 FOR CORRELATED TASTE VARIATION. C (STORED IN IUSER.) C NPAR.... NUMBER OF PARAMETERS IN VECTOR X. C PROB.... ON RETURN, CHOICE PROBABILITY COMPUTED USING PARAMETERS IN C X AND DATA IN ICDAT AND RCDAT. C RCDAT... VECTOR OF REAL DATA VALUES. C IN THIS SUBROUTINE, THE NUMBER OF DATA VALUES SHOULD C BE = IALT * NATTR SO THAT THE "GENERIC" PART OF THE C SCALE VALUE V MAY BE COMPUTED. C NALT.... TOTAL NUMBER OF NOMINAL CHOICE ALTERNATIVES (IF APPLICABLE). C IF ICSET .NE. 0 AND IDUM = 1 OR ICOV = 1 (OR BOTH), THEN C NALT SHOULD BE EQUAL TO ICSET. C OTHERWISE, NALT SHOULD BE > 0 IF EITHER IDUM OR ICOV C (OR BOTH) ARE > 0, AND ICDAT SHOULD BE USED TO PASS C INDEX INFORMATION (SEE ICDAT ABOVE). C NATTR... NUMBER OF ATTRIBUTES (I.E., REAL DATA VARS.) PER ALTERNATIVE. C NW...... NUMBER OF ROWS IN THE WORK-ARRAY W. C RUSER... MODEL-RELATED REAL VALUES USED BY CALCPR. FOR THIS MODEL, C IT CONTAINS A CONSTANT FOR THE COVARIANCE MATRIX SCALE, C AND INFORMATION USED FOR COMPUTING STEP SIZES IN FINITE- C DIFFERENCE CALCULATIONS. C SIGU.... MATRIX CONTAINING THE "UNPACKED" THE FULL COVARIANCE MATRIX C FOR ALL NALT ALTERNATIVE-SPECIFIC ERROR TERMS. THE C MATRIX IS OF DIMENSION 2 TO FACILITATE CODING. THE C NORMALIZATION USED LEAVES A ROW OF ZEROS IN THE LAST C (NALT) ROW. IT IS COMPUTED BEFORE THE CALL TO MINIMIZE C WORK WHEN CALLS ARE TO BE REPEATED. C W....... ARRAY CONTAINING WORKSPACE FOR COVARIANCE COMPUTATIONS. C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C EXTERNAL DL7VML, DV7SCP C INTEGER I, IALTM1, ICOL, ICOV, ICSET, ID, IDUM, IFAULT, IIR, 1 IOUNIT, IPCOEF, IPDUM, IPT, IPTAST, IROW, ISCALE, ISZ, 2 ITASTE, IX, J, JP, K, KP C INTEGER MAXALT, MAXAM1, LR PARAMETER (MAXALT=20, MAXAM1=MAXALT-1, LR=MAXAM1*(MAXAM1-1)/2) C DOUBLE PRECISION SCALE, SII DOUBLE PRECISION V(MAXALT), SIGMA(MAXALT,MAXALT) DOUBLE PRECISION Z(MAXAM1), SIGZ(MAXAM1,MAXAM1), R(LR) C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C SET UP V AND SIGMA MATRIX FOR MNP SPECIFICATION. C C ALTERNATIVE-SPECIFIC DUMMIES: C IALTM1 = IALT - 1 IDUM = IUSER(8) IF (IDUM.NE.0) THEN IPDUM = IUSER(12) C CASE 1: ICSET = 0. ICSET = IUSER(5) IF (ICSET.EQ.0) THEN DO 10 I = 1, IALT IX = ICDAT(I) IF (IX.NE.NALT) THEN V(I) = X(IX+IPDUM) ELSE V(I) = ZERO ENDIF 10 CONTINUE ELSE C CASE 2: ICSET.NE.0 V(IALT) = ZERO DO 20 I = 1, IALTM1 V(I) = X(I+IPDUM) 20 CONTINUE ENDIF ELSE CALL DV7SCP(IALT, V, ZERO) ENDIF C C BETA COEFFICIENTS: C NATTR = IUSER(7) IF (NATTR.NE.0) THEN IPCOEF = IUSER(11) ID = 0 DO 30 I = 1, IALT DO 30 K = 1, NATTR ID = ID + 1 V(I) = V(I) + X(IPCOEF+K)*RCDAT(ID) 30 CONTINUE ENDIF C C ALTERNATIVE-SPECIFIC ERRORS: C ICOV = IUSER(9) IF (ICOV.NE.0) THEN ICSET = IUSER(5) IF (ICSET.EQ.0) THEN DO 40 I = 1, IALT IROW = ICDAT(I) DO 40 J = 1, I ICOL = ICDAT(J) IF (ICOL.LE.IROW) THEN SIGMA(I,J) = SIGU(IROW,ICOL) ELSE SIGMA(I,J) = SIGU(ICOL,IROW) ENDIF 40 CONTINUE ELSE DO 50 I = 1, IALT DO 50 J = 1, I SIGMA(I,J) = SIGU(I,J) 50 CONTINUE ENDIF ELSE ISCALE = IUSER(18) SCALE = RUSER(ISCALE) DO 60 I = 1, IALT DO 60 J = 1, I IF (I.EQ.J) THEN SIGMA(I,J) = SCALE ELSE SIGMA(I,J) = ZERO ENDIF 60 CONTINUE ENDIF C C TASTE VARIATION: C ITASTE = IUSER(10) IF (ITASTE.EQ.1) THEN C UNCORRELATED TASTE VARIATION C SET UP W MATRIX: ID = 0 IPTAST = IUSER(14) DO 70 J = 1, IALT IPT = IPTAST DO 70 K = 1, NATTR IPT = IPT + 1 ID = ID + 1 W(K,J) = X(IPT) * RCDAT(ID) 70 CONTINUE ENDIF C IF (ITASTE.EQ.2) THEN C CORRELATED TASTE VARIATION C SET UP W MATRIX: ID = 1 IPTAST = IUSER(14) + 1 DO 80 J = 1, IALT CALL DL7VML(NATTR, W(1,J), X(IPTAST), RCDAT(ID)) ID = ID + NATTR 80 CONTINUE ENDIF IF (ITASTE.NE.0) THEN C TASTE VARIATION C ADD W(**T)W TO SIGMA: DO 100 I = 1, IALT DO 100 J = 1, I DO 90 K = 1, NATTR SIGMA(I,J) = SIGMA(I,J) + W(K,I)*W(K,J) 90 CONTINUE 100 CONTINUE ENDIF C C SYMMETRIZE SIGMA (MAY NOT BE NECESSARY???) C C IF ((ICOV.NE.0).OR.(ITASTE.NE.0)) THEN DO 110 I = 1, IALT DO 110 J = 1, I SIGMA(J,I) = SIGMA(I,J) 110 CONTINUE C ENDIF C C LOWER DIMENSION VIA STANDARD TRANSFORMATION C (REF. PAGE 43 OF DAGANZO OR BUNCH(1991)) ISZ = 0 SII = SIGMA(ICH,ICH) DO 130 JP = 1, IALT IF (JP.LT.ICH) THEN J = JP ELSE J = JP - 1 ENDIF IF (JP.NE.ICH) THEN Z(J) = V(JP)-V(ICH) DO 120 KP = 1, JP IF (KP.LT.ICH) THEN K = KP ELSE K = KP - 1 ENDIF IF(KP.NE.ICH) THEN ISZ = ISZ + 1 SIGZ(J,K)=SIGMA(JP,KP)-SIGMA(ICH,KP)-SIGMA(ICH,JP)+SII ENDIF 120 CONTINUE ENDIF 130 CONTINUE C IIR = 0 DO 150 J = 1, IALTM1 IF (SIGZ(J,J).LE.ZERO) THEN IERR = 0 RETURN ENDIF SIGZ(J,J) = SQRT(SIGZ(J,J)) Z(J) = Z(J)/SIGZ(J,J) DO 140 K = 1, J-1 IIR = IIR + 1 R(IIR) = SIGZ(J,K)/SIGZ(J,J)/SIGZ(K,K) 140 CONTINUE 150 CONTINUE C IERR = 1 CALL MNPCDF(IALTM1, Z, R, PROB, IFAULT) IF (IFAULT.NE.0) then IERR = 0 IOUNIT = IUSER(3) WRITE(IOUNIT,*) ' Problem evaluating mnpcdf' ENDIF C *** LAST LINE OF CALCP1 FOLLOWS *** END SUBROUTINE CALCDP(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB0, DP, IUSER, RUSER, MNPCDF) C C *** THIS SUBROUTINE CALCULATES FINITE-DIFFERENCE DERIVATIVES FOR *** C *** CHOICE PROBABILITIES. THIS VERSION ASSUMES THAT THE CALCPR *** C *** BEING CALLED IS THE ONE FOR MULTINOMIAL PROBIT. HOWEVER, *** C *** THE CHANGES REQUIRED FOR OTHER MODELS SHOULD BE MINOR. *** C *** NOTE: THIS SUBROUTINE REQUIRES DS7GRD, AND THE ARRAYS ALPHA *** C *** AND D SHOULD HAVE THE SAME DIMENSION AS X. *** C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER NPAR, IERR, ICH, IALT, II, ICDAT(*), IR, IUSER(*) DOUBLE PRECISION X(NPAR), RCDAT(*), PROB0, DP(NPAR), RUSER(*) EXTERNAL MNPCDF C EXTERNAL CALCPR, DS7GRD, DV7SCP INTEGER I, ICOV, IETA0, IPCOV, IPP, IPU, IPUP, IRC, ISCALE, ISIGP, 1 ISIGU, J, NALT, NALTM1, NFC DOUBLE PRECISION ETA, ETA0, PROB, SCALE, XTEMP C INTEGER LX DOUBLE PRECISION ONE, ZERO PARAMETER (ZERO=0.D0, ONE=1.D0, LX=60) C DOUBLE PRECISION ALPHA(LX), D(LX), WRK(6) C C *** PARAMETER USAGE *** C C SEE CALCPR AND CALCP1 C C *** BODY *** C IERR = 1 ICOV = IUSER(9) NALT = IUSER(6) NALTM1 = NALT - 1 ISCALE = IUSER(18) SCALE = RUSER(ISCALE) IETA0 = IUSER(17) ETA0 = RUSER(IETA0) C DO 10 I = 1, NPAR ALPHA(I) = ONE D(I) = ONE 10 CONTINUE C ETA = ETA0 C ETA = ETA0/PROB IRC = 0 C PROB = PROB0 20 CONTINUE CALL DS7GRD(ALPHA, D, ETA, PROB, DP, IRC, 1 NPAR, WRK, X) IF (IRC.EQ.0) GO TO 40 C IF ICOV.NE.0, SET UP AN UNPACKED SIGMA MATRIX IF (ICOV.NE.0) THEN C SQUARE THE CHOLESKY FACTOR TO GET (PACKED) SIGMA: IPCOV = IUSER(13) XTEMP = X(IPCOV) X(IPCOV) = SCALE ISIGP = IUSER(15) CALL DL7SQR(NALTM1, RUSER(ISIGP), X(IPCOV)) X(IPCOV) = XTEMP C "UNPACK" FOR EASIER ACCESS IN CALCPR: IPP = ISIGP - 1 ISIGU = IUSER(16) CALL DV7SCP(NALT*NALT, RUSER(ISIGU), ZERO) IPUP = ISIGU - 1 DO 30 I = 1, NALTM1 IPU = I + IPUP DO 30 J = 1, I IPP = IPP + 1 RUSER(IPU) = RUSER(IPP) IPU = IPU + NALT 30 CONTINUE ENDIF CALL CALCPR(NPAR, X, NFC, ICH, IALT, II, ICDAT, 1 IR, RCDAT, PROB, IUSER, RUSER, MNPCDF) IF (NFC.EQ.0) THEN IERR = 0 RETURN ENDIF GO TO 20 40 CONTINUE C C *** LAST LINE OF CALCDP FOLLOWS *** END SUBROUTINE DS7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X) C C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME *** C *** THIS IS SGRAD2 FROM TOMS ALGORITHM 611. 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 EXTERNAL DR7MDC DOUBLE PRECISION DR7MDC C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. 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) 50, 10, 110 C C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS *** C C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE C SQUARE-ROOT OF MACHEP. C 10 W(1) = DR7MDC(3) W(2) = SQRT(W(1)) C W(FX0) = FX C C *** INCREMENT I AND START COMPUTING G(I) *** C 20 I = ABS(IRC) + 1 IF (I .GT. N) GO TO 120 IRC = I AFX = ABS(W(FX0)) MACHEP = W(1) H0 = W(2) HMIN = HMIN0 * MACHEP W(XISAVE) = X(I) AXI = ABS(X(I)) AXIBAR = MAX(AXI, ONE/D(I)) GI = G(I) AGI = ABS(GI) ETA = ABS(ETA0) IF (AFX .GT. ZERO) ETA = MAX(ETA, AGI*AXI*MACHEP/AFX) ALPHAI = ALPHA(I) IF (ALPHAI .EQ. ZERO) GO TO 80 IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 90 AFXETA = AFX*ETA AAI = ABS(ALPHAI) C C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE. C IF (GI**2 .LE. AFXETA*AAI) GO TO 30 H = TWO* SQRT(AFXETA/AAI) H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI)) GO TO 40 30 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE) H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI)) C C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL *** C 40 H = MAX(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 70 C C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE. C DISCON = C2000*AFXETA H = DISCON/(AGI + SQRT(GI**2 + AAI*DISCON)) C C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG *** C H = MAX(H, HMIN*AXIBAR) IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE) C C *** COMPUTE CENTRAL DIFFERENCE *** C IRC = -I GO TO 100 C 50 H = -W(HSAVE) I = ABS(IRC) IF (H .GT. ZERO) GO TO 60 W(FH) = FX GO TO 100 C 60 G(I) = (W(FH) - FX) / (TWO * H) X(I) = W(XISAVE) GO TO 20 C C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES *** C 70 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR IF (ALPHAI*GI .LT. ZERO) H = -H GO TO 100 80 H = AXIBAR GO TO 100 90 H = H0 * AXIBAR C 100 X(I) = W(XISAVE) + H W(HSAVE) = H GO TO 999 C C *** COMPUTE ACTUAL FORWARD DIFFERENCE *** C 110 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 120 FX = W(FX0) IRC = 0 C 999 RETURN C *** LAST CARD OF DS7GRD FOLLOWS *** END SUBROUTINE PCMRJ(NOBS, NPAR, X, NF, NEED, R, RP, UI, UR, UF) INTEGER NOBS, NPAR, NF, NEED(2), UI(*) DOUBLE PRECISION X(NPAR), R(NOBS), RP(NPAR,NOBS), UR(*) EXTERNAL UF C EXTERNAL PCMRJ1 C INTEGER ICP, IICDAT, IICH, IIIV, IIRV, IIU, INALT, IRCDAT, IRU C C *** BODY *** C IIU = UI(1) IICH = UI(2) INALT = UI(3) IIIV = UI(4) IIRV = UI(5) IICDAT = UI(6) C IRU = UI(7) ICP = UI(8) C IRW = UI(9) IRCDAT = UI(10) C CALL PCMRJ1(NOBS, NPAR, X, NF, NEED, R, RP, 1 UI(IIU), UI(IICH), UI(INALT), UI(IIIV), UI(IIRV), UI(IICDAT), 2 UR(IRU), UR(ICP), UR(IRCDAT), UF) 999 RETURN C *** LAST LINE OF PCMRJ FOLLOWS *** END SUBROUTINE PCMRJ1(NOBS, NPAR, X, NF, NEED, R, RP, 1 IUSER, ICHV, NALTV, IIV, IRV, ICDAT, 2 RUSER, CPROB, RCDAT, UF) C C *** THIS SUBROUTINE EXPANDS THE STORAGE IN UI AND UR TO MAKE THEM *** C *** COMPATIBLE WITH ESTIMATION OF CHOICE MODELS. *** C INTEGER NOBS, NPAR, NF, NEED(2), IUSER(*), ICHV(NOBS), 1 NALTV(NOBS), IIV(NOBS), IRV(NOBS), ICDAT(*) DOUBLE PRECISION X(NPAR), R(NOBS), RP(NPAR,NOBS), RUSER(*), 1 CPROB(NOBS,2), RCDAT(*) EXTERNAL UF C EXTERNAL CALCDP, CALCPR, DL7SQR, DV7SCP C INTEGER I, IALT, ICH, ICOV, IERR, II, III, IIR, IOBS, IOUNIT, 1 IPCOV, IPP, IPU, IPUP, IR, ISCALE, ISIGP, ISIGU, J, KS, 2 NALT, NALTM1, NFC DOUBLE PRECISION PROB, SCALE, XTEMP C INTEGER LX DOUBLE PRECISION ONE, ZERO PARAMETER (ZERO=0.D0, ONE=1.D0, LX=60) C C ARRAYS: C C CPROB... VECTOR FOR STORING CHOICE PROBABILITIES. CPROB(IOBS,J) C FOR J=1,2 STORES CHOICE PROBABILITIES FOR OBSERVATION C IOBS. ONE IS THE CURRENT PROBABILITY, WHILE THE OTHER C ONE IS THE PROBABILITY COMPUTED AT THE PREVIOUS TRIAL C X. THE CODE KEEPS TRACK OF WHICH IS WHICH USING THE C POINTERS STORED IN IUSER(1) AND IUSER(2). THIS IS USED C IN VARIOUS WAYS TO MAKE COMPUTATION MORE EFFICIENT. C ICHV.... VECTOR OF LENGTH NOBS. ICHV(IOBS) CONTAINS THE INDEX OF C THE CHOSEN ALTERNATIVE FOR OBSERVATION IOBS. C IIV..... VECTOR OF LENGHT NOBS. IIV(IOBS) INDICATES THE NUMBER OF C INTEGER DATA VALUES STORED IN ICDAT FOR OBSERVATION IOBS. C IRV..... VECTOR OF LENGHT NOBS. IRV(IOBS) INDICATES THE NUMBER OF C REAL DATA VALUES STORED IN RCDAT FOR OBSERVATION IOBS. C NALTV... VECTOR OF LENGHT NOBS. NALTV(IOBS) INDICATES THE NUMBER OF C CHOICES AVAILABLE FOR OBSERVATION IOBS. C C *** BODY *** C ICOV = IUSER(9) NALT = IUSER(6) NALTM1 = NALT - 1 ISCALE = IUSER(18) SCALE = RUSER(ISCALE) C IF (NEED(1).EQ.1) THEN C C *** CALCULATE RESIDUAL VECTOR *** KS = 1 IF (NEED(2).EQ.IUSER(1)) KS = 2 IUSER(KS) = NF C C IF ICOV.NE.0, SET UP AN UNPACKED SIGMA MATRIX IF (ICOV.NE.0) THEN C SQUARE THE CHOLESKY FACTOR TO GET (PACKED) SIGMA: IPCOV = IUSER(13) XTEMP = X(IPCOV) X(IPCOV) = SCALE ISIGP = IUSER(15) CALL DL7SQR(NALTM1, RUSER(ISIGP), X(IPCOV)) X(IPCOV) = XTEMP C "UNPACK" FOR EASIER ACCESS IN CALCPR: IPP = ISIGP - 1 ISIGU = IUSER(16) CALL DV7SCP(NALT*NALT, RUSER(ISIGU), ZERO) IPUP = ISIGU - 1 DO 10 I = 1, NALTM1 IPU = I + IPUP DO 10 J = 1, I IPP = IPP + 1 RUSER(IPU) = RUSER(IPP) IPU = IPU + NALT 10 CONTINUE ENDIF III = 1 IIR = 1 DO 20 IOBS = 1, NOBS ICH = ICHV(IOBS) IALT = NALTV(IOBS) II = IIV(IOBS) IR = IRV(IOBS) CALL CALCPR(NPAR, X, NFC, ICH, IALT, II, ICDAT(III), 1 IR, RCDAT(IIR), PROB, IUSER, RUSER, UF) IF ((PROB.LE.ZERO).OR.(PROB.GT.ONE).OR.(NFC.EQ.0)) THEN NF = 0 RETURN ENDIF R(IOBS) = PROB CPROB(IOBS,KS) = PROB III = III + II IIR = IIR + IR 20 CONTINUE ELSE C C *** CALCULATE JACOBIAN OF RESIDUAL VECTOR *** C KS = 1 IF (IUSER(1).NE.NF) KS = 2 IF (IUSER(KS).NE.NF) THEN IOUNIT = IUSER(3) WRITE(IOUNIT,*) ' PROBLEM WITH INITIAL ESTIMATE...' ENDIF C III = 1 IIR = 1 DO 30 IOBS = 1, NOBS ICH = ICHV(IOBS) IALT = NALTV(IOBS) II = IIV(IOBS) IR = IRV(IOBS) PROB = CPROB(IOBS,KS) CALL CALCDP(NPAR, X, IERR, ICH, IALT, II, ICDAT(III), 1 IR, RCDAT(IIR), PROB, RP(1,IOBS), IUSER, RUSER, UF) IF (IERR.EQ.0) THEN NF = 0 RETURN ENDIF III = III + II IIR = IIR + IR 30 CONTINUE ENDIF 999 RETURN C *** LAST LINE OF PCMRJ1 FOLLOWS *** END SUBROUTINE PCMRHO(NEED, F, NOBS, NF, XN, R, RD, UI, UR, W) INTEGER NEED(2), NOBS, NF, UI(*) DOUBLE PRECISION F, XN(*), R(*), RD(NOBS,*), UR(*), W(NOBS) C INTEGER ICP, IOBS, IOUNIT, IRW, WEIGHT, KS DOUBLE PRECISION OOR, VT C DOUBLE PRECISION NEGONE, ZERO PARAMETER (NEGONE=-1.D0, ZERO=0.D0) C C *** BODY *** C WEIGHT = UI(14) IF (NEED(1).EQ.1) THEN VT = ZERO IF (WEIGHT.EQ.0) THEN DO 10 IOBS = 1, NOBS VT = VT - LOG(R(IOBS)) 10 CONTINUE ELSE IRW = UI(9) DO 20 IOBS = 1, NOBS VT = VT - UR(IRW) * LOG(R(IOBS)) IRW = IRW + 1 20 CONTINUE ENDIF F = VT ELSE KS = 1 IF (UI(11).NE.NF) KS = 2 IF (UI(10+KS).NE.NF) THEN IOUNIT = UI(13) WRITE(IOUNIT,*) ' PROBLEM WITH INITIAL POINT...' NF = 0 RETURN ENDIF ICP = UI(8) IF (KS.EQ.2) ICP = ICP + NOBS IF (WEIGHT.EQ.0) THEN DO 30 IOBS = 1, NOBS OOR = NEGONE/UR(ICP) R(IOBS) = OOR W(IOBS) = R(IOBS) * OOR RD(IOBS,1) = W(IOBS) ICP = ICP + 1 30 CONTINUE ELSE IRW = UI(9) DO 40 IOBS = 1, NOBS OOR = NEGONE/UR(ICP) R(IOBS) = UR(IRW) * OOR W(IOBS) = R(IOBS) * OOR RD(IOBS,1) = W(IOBS) ICP = ICP + 1 IRW = IRW + 1 40 CONTINUE ENDIF ENDIF 999 RETURN C *** LAST LINE OF PCMRHO FOLLOWS *** END SUBROUTINE FPRINT(NOBS, NPAR, X, NF, UI, UR, UF) INTEGER NOBS, NPAR, NF, UI(*) DOUBLE PRECISION X(NPAR), UR(*) EXTERNAL UF C EXTERNAL FPRNT1 C INTEGER ICP, IICDAT, IICH, IIIV, IIRV, IIU, INALT, IRCDAT, IRU, 1 IRW C C *** BODY *** C IIU = UI(1) IICH = UI(2) INALT = UI(3) IIIV = UI(4) IIRV = UI(5) IICDAT = UI(6) C IRU = UI(7) ICP = UI(8) IRW = UI(9) IRCDAT = UI(10) C CALL FPRNT1(NOBS, NPAR, X, NF, 1 UI(IIU), UI(IICH), UI(INALT), UI(IIIV), UI(IIRV), UI(IICDAT), 2 UR(IRU), UR(IRCDAT), UR(IRW), UF) 999 RETURN C *** LAST LINE OF FPRINT FOLLOWS *** END SUBROUTINE FPRNT1(NOBS, NPAR, X, NF, 1 IUSER, ICHV, NALTV, IIV, IRV, ICDAT, 2 RUSER, RCDAT, WT, UF) C C *** THIS SUBROUTINE EXPANDS THE STORAGE IN UI AND UR TO MAKE THEM *** C *** COMPATIBLE WITH ESTIMATION OF CHOICE MODELS. *** C *** SEE PCMRJ1 DOCUMENTATION ON ARRAYS. *** C INTEGER NOBS, NPAR, NF, IUSER(*), ICHV(NOBS), NALTV(NOBS), 1 IIV(NOBS), IRV(NOBS), ICDAT(*) DOUBLE PRECISION X(NPAR), RUSER(*), RCDAT(*), WT(NOBS) EXTERNAL UF C EXTERNAL CALCPR, DL7SQR, DV7SCP C INTEGER I, IALT, ICH, ICOV, ICSET, II, III, IIR, IOBS, IOUNIT, 1 IPCOV, IPP, IPU, IPUP, IR, ISCALE, ISIGP, ISIGU, J, NALT, 2 NALTM1, NFC DOUBLE PRECISION FPROB(20), PROB, SCALE, XTEMP C INTEGER LX DOUBLE PRECISION ONE, ZERO PARAMETER (ZERO=0.D0, ONE=1.D0, LX=60) C C *** BODY *** C ICOV = IUSER(9) ICSET = IUSER(5) IOUNIT = IUSER(3) NALT = IUSER(6) NALTM1 = NALT - 1 ISCALE = IUSER(18) SCALE = RUSER(ISCALE) C WRITE(IOUNIT, 10) 10 FORMAT(//,' FINAL CHOICE SET PROBABILITIES: ',/) C C IF ICOV.NE.0, SET UP AN UNPACKED SIGMA MATRIX IF (ICOV.NE.0) THEN C SQUARE THE CHOLESKY FACTOR TO GET (PACKED) SIGMA: IPCOV = IUSER(13) XTEMP = X(IPCOV) X(IPCOV) = SCALE ISIGP = IUSER(15) CALL DL7SQR(NALTM1, RUSER(ISIGP), X(IPCOV)) X(IPCOV) = XTEMP C "UNPACK" FOR EASIER ACCESS IN CALCPR: IPP = ISIGP - 1 ISIGU = IUSER(16) CALL DV7SCP(NALT*NALT, RUSER(ISIGU), ZERO) IPUP = ISIGU - 1 DO 20 I = 1, NALTM1 IPU = I + IPUP DO 20 J = 1, I IPP = IPP + 1 RUSER(IPU) = RUSER(IPP) IPU = IPU + NALT 20 CONTINUE ENDIF III = 1 IIR = 1 DO 90 IOBS = 1, NOBS ICH = ICHV(IOBS) IALT = NALTV(IOBS) II = IIV(IOBS) IR = IRV(IOBS) DO 30 I = 1, IALT CALL CALCPR(NPAR, X, NFC, I, IALT, II, ICDAT(III), 1 IR, RCDAT(IIR), PROB, IUSER, RUSER, UF) FPROB(I) = PROB 30 CONTINUE WRITE(IOUNIT, 40) IOBS 40 FORMAT(/,' IOBS: ',I4) IF (ICSET.EQ.0) WRITE(IOUNIT,50) (ICDAT(I),I=1,IALT) 50 FORMAT(' CHOICE SET: ',20I3) WRITE(IOUNIT, 60) IALT, ICH, WT(IOBS) 60 FORMAT(' NO. OF ALTS: ',I2,' ICH: ',I2, 1 ' WT: ',F7.3) WRITE(IOUNIT, 70) (FPROB(I),I=1,IALT) 70 FORMAT(' PROBS: ',8F7.4,/,18X,8F7.4,/,18X,4F7.4) WRITE(IOUNIT, 80) FPROB(ICH) 80 FORMAT(' PROB(ICH): ',F7.4) III = III + II IIR = IIR + IR 90 CONTINUE C 999 RETURN C *** LAST LINE OF FPRNT1 FOLLOWS *** END //GO.SYSIN DD mnpsubs.f cat >pmain.in <<'//GO.SYSIN DD pmain.in' 28 **** problem e1 **** 10 - Example Frome '84 pp. 8-10 (Table 2, In-Vitro Dose Response, 192 Ir radiation) 20 2 1 2 2 6 6 (1X,F5.0,F4.0,F4.1,F6.2) 0 50 0.5 0.25 1 50 0.5 0.25 0 50 0.5 0.25 2 50 0.5 0.25 1 50 0.5 0.25 3 50 0.5 0.25 2 50 0.5 0.25 5 50 1.0 1.0 6 50 1.0 1.0 5 50 1.0 1.0 4 50 1.0 1.0 8 50 1.0 1.0 16 50 2.0 4.0 17 50 2.0 4.0 18 50 2.0 4.0 49 50 4.0 16.0 59 50 4.0 16.0 54 50 4.0 16.0 56 50 4.0 16.0 63 50 4.0 16.0 7 28 **** problem e2.2 **** 10 - Data for model (2.2) in Frome '84. 27 3 1 3 2 6 6 (1X,F4.0,F6.2,F5.1,F6.2,F9.4) 25. 4.78 1.0 1.00 -1.000 102. 19.07 1.0 1.00 -0.6021 149. 22.58 1.0 1.00 -0.3010 160. 23.29 1.0 1.00 0.0000 75. 12.38 1.0 1.00 0.1761 100. 14.91 1.0 1.00 0.3010 99. 15.18 1.0 1.00 0.3979 50. 7.64 1.0 1.00 0.4771 100. 13.67 1.0 1.00 0.6021 52. 3.28 2.5 6.25 -6.250 51. 1.85 2.5 6.25 -3.763 100. 3.42 2.5 6.25 -1.881 100. 3.10 2.5 6.25 0.000 107. 2.78 2.5 6.25 1.101 107. 2.59 2.5 6.25 1.881 102. 2.49 2.5 6.25 2.487 110. 2.98 2.5 6.25 2.982 107. 2.43 2.5 6.25 3.763 100. 2.10 5.0 25.00 -25.00 113. 1.38 5.0 25.00 -15.051 144. 1.60 5.0 25.00 -7.526 106. 1.20 5.0 25.00 0.000 111. 0.90 5.0 25.00 4.402 132. 1.00 5.0 25.00 7.526 419. 3.13 5.0 25.00 9.949 225. 1.82 5.0 25.00 11.928 206. 1.44 5.0 25.00 15.051 7 28 **** problem e2.6 **** 10 - Data for model (2.6) in Frome '84. 27 3 5 2 2 6 6 8.0 1.0 3.1 (1X,F4.0,F6.2,F4.1,F7.3) 25. 4.78 1.0 10.000 102. 19.07 1.0 4.000 149. 22.58 1.0 2.000 160. 23.29 1.0 1.000 75. 12.38 1.0 0.667 100. 14.91 1.0 0.500 99. 15.18 1.0 0.400 50. 7.64 1.0 0.333 100. 13.67 1.0 0.250 52. 3.28 2.5 25.000 51. 1.85 2.5 10.000 100. 3.42 2.5 5.000 100. 3.10 2.5 2.500 107. 2.78 2.5 1.667 107. 2.59 2.5 1.125 102. 2.49 2.5 1.000 110. 2.98 2.5 0.833 107. 2.43 2.5 0.625 100. 2.10 5.0 50.000 113. 1.38 5.0 20.000 144. 1.60 5.0 10.000 106. 1.20 5.0 5.000 111. 0.90 5.0 3.333 132. 1.00 5.0 2.250 419. 3.13 5.0 2.000 225. 1.82 5.0 1.667 206. 1.44 5.0 1.125 7 28 **** problem e2.8 **** 10 - Data for model (2.8) in Frome '84. 30 4 6 2 2 6 6 3.0 2.0 1.0 3.0 (1X,F4.0,F8.0,F9.4,F9.4) 0. 35164. -0.7538 -100.000 0. 3657. -0.7538 -0.6931 0. 8063. -0.7538 1.6094 2. 59965. -0.7538 2.7081 4. 40643. -0.7538 3.4012 0. 3992. -0.7538 3.8067 0. 15134. -0.3483 -100.000 0. 1283. -0.3483 -0.6931 0. 3129. -0.3483 1.6094 2. 16392. -0.3483 2.7081 10. 12839. -0.3483 3.4012 2. 1928. -0.3483 3.8067 25. 213858. -0.06062 -100.000 6. 14624. -0.06062 -0.6931 31. 45217. -0.06062 1.6094 183. 151664. -0.06062 2.7081 245. 103020. -0.06062 3.4012 63. 19649. -0.06062 3.8067 49. 171211. 0.1625 -100.000 10. 10053. 0.1625 -0.6931 44. 37130. 0.1625 1.6094 239. 101731. 0.1625 2.7081 194. 50045. 0.1625 3.4012 50. 8937. 0.1625 3.8067 4. 8489. 0.3448 -100.000 1. 512. 0.3448 -0.6931 5. 1923. 0.3448 1.6094 15. 3867. 0.3448 2.7081 7. 1273. 0.3448 3.4012 3. 232. 0.3448 3.8067 7 28 **** problem e3.1 **** 10 - Data for model (3.1) in Frome '84. 5 2 1 2 6 6 6 (1X,F4.0,2F5.0,F6.0) 15. 600. 1.0 0.0 96. 500. 1.0 30.0 187. 600. 1.0 60.0 100. 300. 1.0 75.0 145. 300. 1.0 90.0 7 28 **** problem e3.3 **** 10 - Data for model (3.3) in Frome '84. 5 2 7 2 6 6 6 .0317714 .00467588 (1X,F4.0,2F5.0,F6.0) 15. 600. 1.0 0.0 96. 500. 1.0 30.0 187. 600. 1.0 60.0 100. 300. 1.0 75.0 145. 300. 1.0 90.0 7 28 **** problem e3.5 **** 10 - Model (3.5), p. 25 of Frome '84 72 9 1 9 8 (1x,f5.0,f4.0,f11.0,9f3.0) 0 199 -0.287682 1. 0. 0. 0. 0. 0. 0. 0. 0 164 0.000000 1. 0. 0. 0. 0. 0. 0. 0. 1 133 0.154151 1. 0. 0. 0. 0. 0. 0. 0. 0 115 0.223144 1. 0. 0. 0. 0. 0. 0. 0. 1 205 0.287682 1. 0. 0. 0. 0. 0. 0. 0. 0 153 0.348307 1. 0. 0. 0. 0. 0. 0. 0. 6 555 0.405465 1. 0. 0. 0. 0. 0. 0. 0. 20 762 0.693147 1. 0. 0. 0. 0. 0. 0. 0. 17 100 1.011601 1. 0. 0. 0. 0. 0. 0. 0. 1 147 -0.287682 0. 1. 0. 0. 0. 0. 0. 0. 1 51 0.000000 0. 1. 0. 0. 0. 0. 0. 0. 1 42 0.154151 0. 1. 0. 0. 0. 0. 0. 0. 1 75 0.223144 0. 1. 0. 0. 0. 0. 0. 0. 2 66 0.287682 0. 1. 0. 0. 0. 0. 0. 0. 4 69 0.348307 0. 1. 0. 0. 0. 0. 0. 0. 342014 0.405465 0. 1. 0. 0. 0. 0. 0. 0. 1642109 0.693147 0. 1. 0. 0. 0. 0. 0. 0. 135 445 1.011601 0. 1. 0. 0. 0. 0. 0. 0. 1 76 -0.287682 0. 0. 1. 0. 0. 0. 0. 0. 2 27 0.000000 0. 0. 1. 0. 0. 0. 0. 0. 0 25 0.154151 0. 0. 1. 0. 0. 0. 0. 0. 1 35 0.223144 0. 0. 1. 0. 0. 0. 0. 0. 2 61 0.287682 0. 0. 1. 0. 0. 0. 0. 0. 5 443 0.348307 0. 0. 1. 0. 0. 0. 0. 0. 201102 0.405465 0. 0. 1. 0. 0. 0. 0. 0. 1281361 0.693147 0. 0. 1. 0. 0. 0. 0. 0. 72 200 1.011601 0. 0. 1. 0. 0. 0. 0. 0. 0 52 -0.287682 0. 0. 0. 1. 0. 0. 0. 0. 1 14 0.000000 0. 0. 0. 1. 0. 0. 0. 0. 2 14 0.154151 0. 0. 0. 1. 0. 0. 0. 0. 0 20 0.223144 0. 0. 0. 1. 0. 0. 0. 0. 3 304 0.287682 0. 0. 0. 1. 0. 0. 0. 0. 6 302 0.348307 0. 0. 0. 1. 0. 0. 0. 0. 15 550 0.405465 0. 0. 0. 1. 0. 0. 0. 0. 98 888 0.693147 0. 0. 0. 1. 0. 0. 0. 0. 42 103 1.011601 0. 0. 0. 1. 0. 0. 0. 0. 0 345 -0.287682 0. 0. 0. 0. 1. 0. 0. 0. 2 283 0.000000 0. 0. 0. 0. 1. 0. 0. 0. 1 243 0.154151 0. 0. 0. 0. 1. 0. 0. 0. 3 203 0.223144 0. 0. 0. 0. 1. 0. 0. 0. 6 287 0.287682 0. 0. 0. 0. 1. 0. 0. 0. 8 230 0.348307 0. 0. 0. 0. 1. 0. 0. 0. 13 441 0.405465 0. 0. 0. 0. 1. 0. 0. 0. 118 758 0.693147 0. 0. 0. 0. 1. 0. 0. 0. 30 67 1.011601 0. 0. 0. 0. 1. 0. 0. 0. 0 186 -0.287682 0. 0. 0. 0. 0. 1. 0. 0. 0 153 0.000000 0. 0. 0. 0. 0. 1. 0. 0. 0 124 0.154151 0. 0. 0. 0. 0. 1. 0. 0. 1 109 0.223144 0. 0. 0. 0. 0. 1. 0. 0. 7 193 0.287682 0. 0. 0. 0. 0. 1. 0. 0. 9 166 0.348307 0. 0. 0. 0. 0. 1. 0. 0. 17 382 0.405465 0. 0. 0. 0. 0. 1. 0. 0. 118 587 0.693147 0. 0. 0. 0. 0. 1. 0. 0. 37 75 1.011601 0. 0. 0. 0. 0. 1. 0. 0. 1 168 -0.287682 0. 0. 0. 0. 0. 0. 1. 0. 3 149 0.000000 0. 0. 0. 0. 0. 0. 1. 0. 1 127 0.154151 0. 0. 0. 0. 0. 0. 1. 0. 5 99 0.223144 0. 0. 0. 0. 0. 0. 1. 0. 2 100 0.287682 0. 0. 0. 0. 0. 0. 1. 0. 3 85 0.348307 0. 0. 0. 0. 0. 0. 1. 0. 19 213 0.405465 0. 0. 0. 0. 0. 0. 1. 0. 76 297 0.693147 0. 0. 0. 0. 0. 0. 1. 0. 22 31 1.011601 0. 0. 0. 0. 0. 0. 1. 0. 1 169 -0.287682 0. 0. 0. 0. 0. 0. 0. 1. 2 152 0.000000 0. 0. 0. 0. 0. 0. 0. 1. 1 127 0.154151 0. 0. 0. 0. 0. 0. 0. 1. 1 100 0.223144 0. 0. 0. 0. 0. 0. 0. 1. 7 110 0.287682 0. 0. 0. 0. 0. 0. 0. 1. 1 82 0.348307 0. 0. 0. 0. 0. 0. 0. 1. 24 211 0.405465 0. 0. 0. 0. 0. 0. 0. 1. 126 314 0.693147 0. 0. 0. 0. 0. 0. 0. 1. 9 11 1.011601 0. 0. 0. 0. 0. 0. 0. 1. 7 28 **** problem ex1 **** 10 - PRLRT1.DAT: RC3- BIOMETRICS ( 1965 ) P. 613 11 2 1 2 2 6 6 (1X,F5.0,F4.0,2F7.4) 24 4 0.0500 0.0025 90 5 0.1000 0.0100 110 5 0.1500 0.0225 160 5 0.2000 0.0400 165 5 0.2500 0.0625 220 5 0.3000 0.0900 195 5 0.3500 0.1225 245 5 0.4000 0.1600 208 4 0.4500 0.2025 295 5 0.5000 0.2500 204 3 0.6000 0.3600 7 28 **** problem ex2 **** 10 - PRLLT3.DAT: NELDER-WEDDERBURN (1972) P.378 20 9 2 9 2 6 6 (1X,F3.0,9F3.0,F4.0) 7 1 1 0 0 0 0 0 0 0 -8 3 1 1 0 0 0 0 1 0 0 -6 4 1 1 0 0 0 0 0 1 0 -4 7 1 1 0 0 0 0 0 0 1 -2 13 1 1 1 0 0 0 0 0 0 -4 11 1 1 1 0 0 0 1 0 0 -3 15 1 1 1 0 0 0 0 1 0 -2 10 1 1 1 0 0 0 0 0 1 -1 7 1 1 0 1 0 0 0 0 0 0 11 1 1 0 1 0 0 1 0 0 0 9 1 1 0 1 0 0 0 1 0 0 23 1 1 0 1 0 0 0 0 1 0 10 1 1 0 0 1 0 0 0 0 4 12 1 1 0 0 1 0 1 0 0 3 9 1 1 0 0 1 0 0 1 0 2 28 1 1 0 0 1 0 0 0 1 1 3 1 1 0 0 0 1 0 0 0 8 4 1 1 0 0 0 1 1 0 0 6 5 1 1 0 0 0 1 0 1 0 4 32 1 1 0 0 0 1 0 0 1 2 7 28 **** problem ex3 **** 10 - PRNLT1.DAT: TILL AND MCCUL. (1961) DATA-- TARGET MODEL 7 3 3 2 3 6 6 8.0 1.0 3.1 (1X,F5.0,F5.0,F7.2,F5.2) 60. 6. 1.25 0.00 66. 7. 1.75 0.96 46. 4. 3.00 1.92 82. 9. 7.20 2.88 105. 11. 24.00 4.32 123. 15. 75.00 5.76 12. 4. 120.00 6.72 7 28 **** problem ex8-10 **** 10 - Example Frome '84 pp. 8-10 (Table 2, In-Vitro Dose Response, 192 Ir radiation) 4 2 1 2 2 6 6 (1X,F5.0,F4.0,F4.1,F6.2) 9 350 0.5 0.25 28 250 1.0 1.0 51 150 2.0 4.0 281 250 4.0 16.0 7 28 **** problem mn202 **** 10 - Example on p. 202 of McCullagh and Nelder 64 7 11 3 10 6 6 1.,1.,40.,2.,22., 3.,32. (F5.2,F3.0,3F5.0) 1.98 1. 0. 0. 0. 2.38 1. 0. 22. 0. 2.18 1. 0. 44. 0. 2.22 1. 0. 88. 0. 3.88 1. 100. 0. 0. 4.35 1. 100. 22. 0. 4.14 1. 100. 44. 0. 4.26 1. 100. 88. 0. 4.40 1. 200. 0. 0. 5.01 1. 200. 22. 0. 4.77 1. 200. 44. 0. 5.17 1. 200. 88. 0. 4.43 1. 400. 0. 0. 4.95 1. 400. 22. 0. 5.22 1. 400. 44. 0. 5.66 1. 400. 88. 0. 2.13 1. 0. 0. 42. 2.24 1. 0. 22. 42. 2.56 1. 0. 44. 42. 2.47 1. 0. 88. 42. 3.91 1. 100. 0. 42. 4.59 1. 100. 22. 42. 4.36 1. 100. 44. 42. 4.72 1. 100. 88. 42. 4.91 1. 200. 0. 42. 5.64 1. 200. 22. 42. 5.69 1. 200. 44. 42. 5.45 1. 200. 88. 42. 5.31 1. 400. 0. 42. 6.27 1. 400. 22. 42. 6.27 1. 400. 44. 42. 6.24 1. 400. 88. 42. 2.19 1. 0. 0. 84. 2.10 1. 0. 22. 84. 2.22 1. 0. 44. 84. 2.94 1. 0. 88. 84. 3.66 1. 100. 0. 84. 4.47 1. 100. 22. 84. 4.55 1. 100. 44. 84. 4.83 1. 100. 88. 84. 5.10 1. 200. 0. 84. 5.68 1. 200. 22. 84. 5.80 1. 200. 44. 84. 5.85 1. 200. 88. 84. 5.15 1. 400. 0. 84. 6.49 1. 400. 22. 84. 6.35 1. 400. 44. 84. 7.11 1. 400. 88. 84. 1.97 1. 0. 0. 168. 2.60 1. 0. 22. 168. 2.47 1. 0. 44. 168. 2.48 1. 0. 88. 168. 4.07 1. 100. 0. 168. 4.55 1. 100. 22. 168. 4.35 1. 100. 44. 168. 4.85 1. 100. 88. 168. 5.23 1. 200. 0. 168. 5.60 1. 200. 22. 168. 6.07 1. 200. 44. 168. 6.43 1. 200. 88. 168. 5.87 1. 400. 0. 168. 6.54 1. 400. 22. 168. 6.72 1. 400. 44. 168. 7.32 1. 400. 88. 168. 7 28 **** problem mn202.1 **** 10 - Example on p. 202 of McCullagh and Nelder 64 7 11 3 10 6 6 1.,2.,3.,4.,5. 6.,7. (F5.2,F3.0,3F5.0) 1.98 1. 0. 0. 0. 2.38 1. 0. 22. 0. 2.18 1. 0. 44. 0. 2.22 1. 0. 88. 0. 3.88 1. 100. 0. 0. 4.35 1. 100. 22. 0. 4.14 1. 100. 44. 0. 4.26 1. 100. 88. 0. 4.40 1. 200. 0. 0. 5.01 1. 200. 22. 0. 4.77 1. 200. 44. 0. 5.17 1. 200. 88. 0. 4.43 1. 400. 0. 0. 4.95 1. 400. 22. 0. 5.22 1. 400. 44. 0. 5.66 1. 400. 88. 0. 2.13 1. 0. 0. 42. 2.24 1. 0. 22. 42. 2.56 1. 0. 44. 42. 2.47 1. 0. 88. 42. 3.91 1. 100. 0. 42. 4.59 1. 100. 22. 42. 4.36 1. 100. 44. 42. 4.72 1. 100. 88. 42. 4.91 1. 200. 0. 42. 5.64 1. 200. 22. 42. 5.69 1. 200. 44. 42. 5.45 1. 200. 88. 42. 5.31 1. 400. 0. 42. 6.27 1. 400. 22. 42. 6.27 1. 400. 44. 42. 6.24 1. 400. 88. 42. 2.19 1. 0. 0. 84. 2.10 1. 0. 22. 84. 2.22 1. 0. 44. 84. 2.94 1. 0. 88. 84. 3.66 1. 100. 0. 84. 4.47 1. 100. 22. 84. 4.55 1. 100. 44. 84. 4.83 1. 100. 88. 84. 5.10 1. 200. 0. 84. 5.68 1. 200. 22. 84. 5.80 1. 200. 44. 84. 5.85 1. 200. 88. 84. 5.15 1. 400. 0. 84. 6.49 1. 400. 22. 84. 6.35 1. 400. 44. 84. 7.11 1. 400. 88. 84. 1.97 1. 0. 0. 168. 2.60 1. 0. 22. 168. 2.47 1. 0. 44. 168. 2.48 1. 0. 88. 168. 4.07 1. 100. 0. 168. 4.55 1. 100. 22. 168. 4.35 1. 100. 44. 168. 4.85 1. 100. 88. 168. 5.23 1. 200. 0. 168. 5.60 1. 200. 22. 168. 6.07 1. 200. 44. 168. 6.43 1. 200. 88. 168. 5.87 1. 400. 0. 168. 6.54 1. 400. 22. 168. 6.72 1. 400. 44. 168. 7.32 1. 400. 88. 168. 7 28 **** problem mn204 **** 10 - Example on p. 205 of McCullagh and Nelder 15 4 9 2 7 6 6 1., 1., 1., 1. (1X,F3.0,F4.0,F4.0,F6.2) 7 100 4. 0. 59 200 5. 0. 115 300 8. 0. 149 300 10. 0. 178 300 15. 0. 229 300 20. 0. 5 100 2. 3.9 43 100 5. 3.9 76 100 10. 3.9 4 100 2. 19.5 57 100 5. 19.5 83 100 10. 19.5 6 100 2. 39. 57 100 5. 39. 84 100 10. 39. 7 28 **** problem mn205 **** 10 - Example on p. 204-5 of McCullagh and Nelder 15 5 10 2 7 6 6 1., 1., 1., 1., 1. (1X,F3.0,F4.0,F4.0,F6.2) 7 100 4. 0. 59 200 5. 0. 115 300 8. 0. 149 300 10. 0. 178 300 15. 0. 229 300 20. 0. 5 100 2. 3.9 43 100 5. 3.9 76 100 10. 3.9 4 100 2. 19.5 57 100 5. 19.5 83 100 10. 19.5 6 100 2. 39. 57 100 5. 39. 84 100 10. 39. 7 28 **** problem mn205.1 **** 10 - Example on p. 205-6 of McCullagh and Nelder 15 5 10 2 7 6 6 -2.896,1.345,1.708,1.674,1.98 (1X,F3.0,F4.0,F4.0,F6.2) 7 100 4. 0. 59 200 5. 0. 115 300 8. 0. 149 300 10. 0. 178 300 15. 0. 229 300 20. 0. 5 100 2. 3.9 43 100 5. 3.9 76 100 10. 3.9 4 100 2. 19.5 57 100 5. 19.5 83 100 10. 19.5 6 100 2. 39. 57 100 5. 39. 84 100 10. 39. 7 28 **** problem speed **** 10 - Speed data from Daryl(14.2): E(y)=b*x+c*x^2, var(y) = phi*E(y)^theta 50 4 1 2 11 6 6 2 1. 0. (1X,2F3.0,4X,F5.0,F8.0) 2 1 1. 4. 16. 10 1 1. 4. 16. 4 1 1. 7. 49. 22 1 1. 7. 49. 16 1 1. 8. 64. 10 1 1. 9. 81. 18 1 1. 10. 100. 26 1 1. 10. 100. 34 1 1. 10. 100. 17 1 1. 11. 121. 28 1 1. 11. 121. 14 1 1. 12. 144. 20 1 1. 12. 144. 24 1 1. 12. 144. 28 1 1. 12. 144. 26 1 1. 13. 169. 34 1 1. 13. 169. 34 1 1. 13. 169. 46 1 1. 13. 169. 26 1 1. 14. 196. 36 1 1. 14. 196. 60 1 1. 14. 196. 80 1 1. 14. 196. 20 1 1. 15. 225. 26 1 1. 15. 225. 54 1 1. 15. 225. 32 1 1. 16. 256. 40 1 1. 16. 256. 32 1 1. 17. 289. 40 1 1. 17. 289. 50 1 1. 17. 289. 42 1 1. 18. 324. 56 1 1. 18. 324. 76 1 1. 18. 324. 84 1 1. 18. 324. 36 1 1. 19. 361. 46 1 1. 19. 361. 68 1 1. 19. 361. 32 1 1. 20. 400. 48 1 1. 20. 400. 52 1 1. 20. 400. 56 1 1. 20. 400. 64 1 1. 20. 400. 66 1 1. 22. 484. 54 1 1. 23. 529. 70 1 1. 24. 576. 92 1 1. 24. 576. 93 1 1. 24. 576. 120 1 1. 24. 576. 85 1 1. 25. 625. 7 28 **** problem textile **** 10 - textile data from Daryl: E(y) = exp(b0+x1*b1+x2*b2+x3*b3), Var(y) = mu^theta 27 6 2 4 11 6 6 4 1. 0. (F4.0,F2.0,4F5.0) 674 1 1. -1. -1. -1. 370 1 1. -1. -1. 0. 292 1 1. -1. -1. 1. 338 1 1. -1. 0. -1. 266 1 1. -1. 0. 0. 210 1 1. -1. 0. 1. 170 1 1. -1. 1. -1. 118 1 1. -1. 1. 0. 90 1 1. -1. 1. 1. 1414 1 1. 0. -1. -1. 1198 1 1. 0. -1. 0. 634 1 1. 0. -1. 1. 1022 1 1. 0. 0. -1. 620 1 1. 0. 0. 0. 438 1 1. 0. 0. 1. 442 1 1. 0. 1. -1. 332 1 1. 0. 1. 0. 220 1 1. 0. 1. 1. 3636 1 1. 1. -1. -1. 3184 1 1. 1. -1. 0. 2000 1 1. 1. -1. 1. 1568 1 1. 1. 0. -1. 1070 1 1. 1. 0. 0. 566 1 1. 1. 0. 1. 1140 1 1. 1. 1. -1. 884 1 1. 1. 1. 0. 360 1 1. 1. 1. 1. 7 28 **** problem insurance (D = I) **** 10 - Insurance data from Daryl. 123 17 1 14 11 6 6 14 1. 0. 1. (16F4.0) 289 8 1 0 0 0 0 0 0 1 0 0 1 0 0 1 372 10 1 0 0 0 0 0 0 0 1 0 1 0 0 1 189 9 1 0 0 0 0 0 0 0 0 1 1 0 0 1 763 3 1 0 0 0 0 0 0 -1 -1 -1 1 0 0 1 302 18 0 1 0 0 0 0 0 1 0 0 1 0 0 1 420 59 0 1 0 0 0 0 0 0 1 0 1 0 0 1 268 44 0 1 0 0 0 0 0 0 0 1 1 0 0 1 407 24 0 1 0 0 0 0 0 -1 -1 -1 1 0 0 1 268 56 0 0 1 0 0 0 0 1 0 0 1 0 0 1 275 125 0 0 1 0 0 0 0 0 1 0 1 0 0 1 334 163 0 0 1 0 0 0 0 0 0 1 1 0 0 1 383 72 0 0 1 0 0 0 0 -1 -1 -1 1 0 0 1 236 43 0 0 0 1 0 0 0 1 0 0 1 0 0 1 259 179 0 0 0 1 0 0 0 0 1 0 1 0 0 1 340 197 0 0 0 1 0 0 0 0 0 1 1 0 0 1 400 104 0 0 0 1 0 0 0 -1 -1 -1 1 0 0 1 207 43 0 0 0 0 1 0 0 1 0 0 1 0 0 1 208 191 0 0 0 0 1 0 0 0 1 0 1 0 0 1 251 210 0 0 0 0 1 0 0 0 0 1 1 0 0 1 233 119 0 0 0 0 1 0 0 -1 -1 -1 1 0 0 1 254 90 0 0 0 0 0 1 0 1 0 0 1 0 0 1 218 380 0 0 0 0 0 1 0 0 1 0 1 0 0 1 239 401 0 0 0 0 0 1 0 0 0 1 1 0 0 1 387 199 0 0 0 0 0 1 0 -1 -1 -1 1 0 0 1 251 69 0 0 0 0 0 0 1 1 0 0 1 0 0 1 196 366 0 0 0 0 0 0 1 0 1 0 1 0 0 1 268 310 0 0 0 0 0 0 1 0 0 1 1 0 0 1 391 105 0 0 0 0 0 0 1 -1 -1 -1 1 0 0 1 264 64 -1 -1 -1 -1 -1 -1 -1 1 0 0 1 0 0 1 224 228 -1 -1 -1 -1 -1 -1 -1 0 1 0 1 0 0 1 269 183 -1 -1 -1 -1 -1 -1 -1 0 0 1 1 0 0 1 385 62 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1 0 0 1 282 8 1 0 0 0 0 0 0 1 0 0 0 1 0 1 249 28 1 0 0 0 0 0 0 0 1 0 0 1 0 1 288 13 1 0 0 0 0 0 0 0 0 1 0 1 0 1 850 2 1 0 0 0 0 0 0 -1 -1 -1 0 1 0 1 194 31 0 1 0 0 0 0 0 1 0 0 0 1 0 1 243 96 0 1 0 0 0 0 0 0 1 0 0 1 0 1 343 39 0 1 0 0 0 0 0 0 0 1 0 1 0 1 320 18 0 1 0 0 0 0 0 -1 -1 -1 0 1 0 1 285 55 0 0 1 0 0 0 0 1 0 0 0 1 0 1 243 172 0 0 1 0 0 0 0 0 1 0 0 1 0 1 274 129 0 0 1 0 0 0 0 0 0 1 0 1 0 1 305 50 0 0 1 0 0 0 0 -1 -1 -1 0 1 0 1 270 53 0 0 0 1 0 0 0 1 0 0 0 1 0 1 226 211 0 0 0 1 0 0 0 0 1 0 0 1 0 1 260 125 0 0 0 1 0 0 0 0 0 1 0 1 0 1 349 55 0 0 0 1 0 0 0 -1 -1 -1 0 1 0 1 129 73 0 0 0 0 1 0 0 1 0 0 0 1 0 1 214 219 0 0 0 0 1 0 0 0 1 0 0 1 0 1 232 131 0 0 0 0 1 0 0 0 0 1 0 1 0 1 325 43 0 0 0 0 1 0 0 -1 -1 -1 0 1 0 1 213 98 0 0 0 0 0 1 0 1 0 0 0 1 0 1 209 434 0 0 0 0 0 1 0 0 1 0 0 1 0 1 250 253 0 0 0 0 0 1 0 0 0 1 0 1 0 1 299 88 0 0 0 0 0 1 0 -1 -1 -1 0 1 0 1 227 120 0 0 0 0 0 0 1 1 0 0 0 1 0 1 229 353 0 0 0 0 0 0 1 0 1 0 0 1 0 1 250 148 0 0 0 0 0 0 1 0 0 1 0 1 0 1 228 46 0 0 0 0 0 0 1 -1 -1 -1 0 1 0 1 198 100 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 1 0 1 193 233 -1 -1 -1 -1 -1 -1 -1 0 1 0 0 1 0 1 258 103 -1 -1 -1 -1 -1 -1 -1 0 0 1 0 1 0 1 324 22 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 0 1 0 1 133 4 1 0 0 0 0 0 0 1 0 0 0 0 1 1 288 1 1 0 0 0 0 0 0 0 1 0 0 0 1 1 179 1 1 0 0 0 0 0 0 0 0 1 0 0 1 1 135 10 0 1 0 0 0 0 0 1 0 0 0 0 1 1 196 13 0 1 0 0 0 0 0 0 1 0 0 0 1 1 293 7 0 1 0 0 0 0 0 0 0 1 0 0 1 1 205 2 0 1 0 0 0 0 0 -1 -1 -1 0 0 1 1 181 17 0 0 1 0 0 0 0 1 0 0 0 0 1 1 179 36 0 0 1 0 0 0 0 0 1 0 0 0 1 1 208 18 0 0 1 0 0 0 0 0 0 1 0 0 1 1 116 6 0 0 1 0 0 0 0 -1 -1 -1 0 0 1 1 160 15 0 0 0 1 0 0 0 1 0 0 0 0 1 1 161 39 0 0 0 1 0 0 0 0 1 0 0 0 1 1 189 30 0 0 0 1 0 0 0 0 0 1 0 0 1 1 147 8 0 0 0 1 0 0 0 -1 -1 -1 0 0 1 1 157 21 0 0 0 0 1 0 0 1 0 0 0 0 1 1 149 46 0 0 0 0 1 0 0 0 1 0 0 0 1 1 204 32 0 0 0 0 1 0 0 0 0 1 0 0 1 1 207 4 0 0 0 0 1 0 0 -1 -1 -1 0 0 1 1 149 35 0 0 0 0 0 1 0 1 0 0 0 0 1 1 172 97 0 0 0 0 0 1 0 0 1 0 0 0 1 1 174 50 0 0 0 0 0 1 0 0 0 1 0 0 1 1 325 8 0 0 0 0 0 1 0 -1 -1 -1 0 0 1 1 172 42 0 0 0 0 0 0 1 1 0 0 0 0 1 1 164 95 0 0 0 0 0 0 1 0 1 0 0 0 1 1 175 33 0 0 0 0 0 0 1 0 0 1 0 0 1 1 346 10 0 0 0 0 0 0 1 -1 -1 -1 0 0 1 1 167 43 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 1 1 178 73 -1 -1 -1 -1 -1 -1 -1 0 1 0 0 0 1 1 227 20 -1 -1 -1 -1 -1 -1 -1 0 0 1 0 0 1 1 192 6 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 0 0 1 1 160 1 1 0 0 0 0 0 0 1 0 0 -1 -1 -1 1 11 1 1 0 0 0 0 0 0 0 1 0 -1 -1 -1 1 166 4 0 1 0 0 0 0 0 1 0 0 -1 -1 -1 1 135 3 0 1 0 0 0 0 0 0 1 0 -1 -1 -1 1 104 2 0 1 0 0 0 0 0 0 0 1 -1 -1 -1 1 110 12 0 0 1 0 0 0 0 1 0 0 -1 -1 -1 1 264 10 0 0 1 0 0 0 0 0 1 0 -1 -1 -1 1 150 8 0 0 1 0 0 0 0 0 0 1 -1 -1 -1 1 636 1 0 0 1 0 0 0 0 -1 -1 -1 -1 -1 -1 1 110 12 0 0 0 1 0 0 0 1 0 0 -1 -1 -1 1 107 19 0 0 0 1 0 0 0 0 1 0 -1 -1 -1 1 104 9 0 0 0 1 0 0 0 0 0 1 -1 -1 -1 1 65 2 0 0 0 1 0 0 0 -1 -1 -1 -1 -1 -1 1 113 14 0 0 0 0 1 0 0 1 0 0 -1 -1 -1 1 137 23 0 0 0 0 1 0 0 0 1 0 -1 -1 -1 1 141 8 0 0 0 0 1 0 0 0 0 1 -1 -1 -1 1 98 22 0 0 0 0 0 1 0 1 0 0 -1 -1 -1 1 110 59 0 0 0 0 0 1 0 0 1 0 -1 -1 -1 1 129 15 0 0 0 0 0 1 0 0 0 1 -1 -1 -1 1 137 9 0 0 0 0 0 1 0 -1 -1 -1 -1 -1 -1 1 98 35 0 0 0 0 0 0 1 1 0 0 -1 -1 -1 1 132 45 0 0 0 0 0 0 1 0 1 0 -1 -1 -1 1 152 13 0 0 0 0 0 0 1 0 0 1 -1 -1 -1 1 167 1 0 0 0 0 0 0 1 -1 -1 -1 -1 -1 -1 1 114 53 -1 -1 -1 -1 -1 -1 -1 1 0 0 -1 -1 -1 1 101 44 -1 -1 -1 -1 -1 -1 -1 0 1 0 -1 -1 -1 1 119 6 -1 -1 -1 -1 -1 -1 -1 0 0 1 -1 -1 -1 1 123 6 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 1 2 16,0 0,0 3 38,1. 0,0 5 0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,2,-1 11 13 7 28 **** problem insurance.1 (D = I) **** 5 0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1.5,-1 7 //GO.SYSIN DD pmain.in cat >daganzo.fu2 <<'//GO.SYSIN DD daganzo.fu2' 2 16.481 16.196 23.890 2 15.123 11.373 14.182 2 19.469 8.822 20.819 2 18.847 15.649 21.280 2 12.578 10.671 18.335 1 11.513 20.582 27.838 1 10.651 15.537 17.418 1 8.359 15.675 21.050 1 11.679 12.668 23.104 2 23.237 10.356 21.346 3 13.236 16.019 10.087 3 20.052 16.861 14.168 2 18.917 14.764 21.564 2 18.200 6.868 19.095 1 10.777 16.554 15.938 2 20.003 6.377 9.314 2 19.768 8.523 18.960 2 8.151 13.845 17.643 1 22.173 18.045 15.535 2 13.134 11.067 19.108 1 14.051 14.247 15.764 3 14.685 10.811 12.361 1 11.666 10.758 16.445 3 17.211 15.201 17.059 1 13.930 16.227 22.024 2 15.237 14.345 19.984 1 10.840 11.071 10.188 2 16.841 11.224 13.417 3 13.913 16.991 26.618 2 13.089 9.822 19.162 3 16.626 10.725 15.285 2 13.477 15.509 24.421 2 20.851 14.557 19.800 2 11.365 12.673 22.212 2 13.296 10.076 17.810 1 15.417 14.103 21.050 2 15.938 11.180 19.851 2 19.034 14.125 19.764 1 10.466 12.481 18.540 3 15.799 16.979 13.074 2 12.713 15.105 13.629 2 16.908 10.958 19.713 2 17.098 6.853 14.502 2 18.608 14.268 18.301 1 11.059 10.812 20.121 2 15.641 10.754 24.669 1 7.822 18.949 16.904 2 12.824 5.697 19.183 2 11.852 12.147 15.672 2 15.557 8.307 22.286 //GO.SYSIN DD daganzo.fu2 cat >mnpex1.fu1 <<'//GO.SYSIN DD mnpex1.fu1' 5 50 3 0 -1 3 6 0 2 0 3 1 1 1 0 TTIME 0. -100. 100. DBUS 0. -100. 100. DSTREETC 0. -100. 100. B21 1. -100. 100. B22 1. -100. 100. Example 1: Trinomial probit model for mode choice, using Daganzo data. This example includes alternative-specific means, correlated alternative- specific errors, and NO random taste variation for traveltime. Explanatory data (for Unit 2 input stream) are in Daganzo.fu2. //GO.SYSIN DD mnpex1.fu1 cat >mnpex2.fu1 <<'//GO.SYSIN DD mnpex2.fu1' 6 50 3 0 -1 3 6 0 2 0 3 1 1 1 1 TTIME 0. -100. 100. DBUS 0. -100. 100. DSTREETC 0. -100. 100. B21 1. -100. 100. B22 1. -100. 100. SigT 1. 0.0001 100. Example 2: Trinomial probit model for mode choice, using Daganzo data. This example includes alternative-specific means, correlated alternative- specific errors, and random taste variation for traveltime. Explanatory data (for Fortran Unit 2) are in Daganzo.fu2. //GO.SYSIN DD mnpex2.fu1 cat >rent.fu2 <<'//GO.SYSIN DD rent.fu2' 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 400. 1. 0. 0. 1. 1. 0. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 615. 1. 0. 1. 0. 0. 1. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 2 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 1 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 695. 1. 0. 0. 0. 0. 1. 0. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 900. 1. 0. 0. 0. 0. 0. 1. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 595. 0. 0. 0. 0. 0. 1. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 885. 0. 1. 0. 1. 0. 0. 1. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 615. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 460. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 1 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 2 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 500. 0. 1. 0. 0. 0. 1. 1. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 1 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 556. 0. 0. 0. 1. 0. 1. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 480. 1. 0. 0. 1. 0. 1. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 500. 1. 0. 0. 1. 0. 0. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 2 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 1250. 0. 0. 0. 1. 0. 0. 1. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 2 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 800. 1. 0. 0. 0. 0. 0. 1. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 1 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 2 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 1 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 1 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 1 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 565. 0. 0. 1. 0. 1. 0. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 1 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 2 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 1 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 2 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 1 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 1 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 760. 0. 0. 0. 1. 0. 0. 0. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 2 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 2 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 1 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 1 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 1 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 2 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 2 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 3 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 1 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 500. 0. 1. 0. 1. 1. 0. 0. 1. 2 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 2 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 1 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 1 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 2 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 1 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 2 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 1 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 2 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 1 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 2 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 1 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 775. 0. 0. 1. 0. 0. 1. 1. 1. 3 900. 0. 1. 1. 0. 0. 1. 0. 0. 650. 0. 0. 0. 1. 0. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 1. 0. 1. 0. 1. 0. 450. 0. 1. 0. 1. 0. 0. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 1. 0. 1. 1. 0. 900. 0. 0. 0. 0. 0. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 1. 0. 0. 0. 0. 450. 1. 0. 0. 0. 0. 0. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 1. 0. 0. 1. 0. 450. 0. 0. 0. 1. 1. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 1. 1. 0. 1. 0. 650. 1. 0. 0. 1. 1. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 1. 1. 0. 0. 0. 650. 0. 0. 1. 0. 0. 1. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 1. 0. 0. 1. 1. 0. 650. 0. 1. 1. 0. 1. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 1. 0. 1. 1. 0. 900. 1. 0. 1. 0. 0. 1. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 1. 0. 0. 0. 1. 0. 900. 1. 0. 0. 1. 0. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 0. 0. 1. 0. 1. 0. 900. 1. 0. 0. 0. 1. 0. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 0. 0. 1. 0. 0. 0. 900. 0. 1. 1. 0. 0. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 1. 0. 0. 0. 1. 0. 1. 0. 900. 0. 0. 0. 1. 0. 1. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 0. 0. 0. 1. 1. 0. 450. 0. 0. 1. 0. 0. 0. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 1. 0. 1. 0. 0. 0. 450. 1. 0. 1. 0. 1. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 0. 0. 0. 0. 1. 0. 650. 1. 0. 1. 0. 0. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 0. 0. 0. 0. 1. 1. 0. 450. 0. 1. 0. 0. 1. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 0. 1. 0. 1. 0. 0. 900. 0. 1. 0. 1. 1. 0. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 1. 1. 0. 1. 0. 1. 0. 450. 0. 0. 0. 0. 0. 1. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 1. 0. 0. 0. 1. 0. 900. 0. 0. 1. 0. 1. 0. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 0. 0. 0. 0. 0. 0. 1. 0. 650. 0. 1. 0. 1. 0. 1. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 650. 1. 0. 0. 0. 0. 0. 0. 0. 650. 0. 0. 0. 0. 1. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 1. 0. 1. 0. 0. 1. 0. 450. 0. 1. 1. 0. 0. 1. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 0. 0. 0. 1. 0. 0. 450. 1. 0. 0. 1. 0. 1. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 900. 0. 0. 1. 0. 0. 1. 1. 0. 650. 1. 0. 0. 0. 0. 1. 0. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 1. 0. 1. 0. 0. 0. 0. 0. 900. 0. 1. 0. 0. 0. 1. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. 3 450. 0. 1. 0. 1. 1. 0. 1. 0. 650. 0. 1. 0. 0. 0. 0. 1. 0. 405. 1. 0. 0. 1. 0. 1. 0. 1. //GO.SYSIN DD rent.fu2 cat >rent1.fu1 <<'//GO.SYSIN DD rent1.fu1' 9 567 3 0 -1 27 6 0 2 3 27 21 1 3 9 0 0 0 RENT -0.371499D-02 -0.100000D+03 0.100000D+03 LocD1 0.473069D-01 -0.100000D+03 0.100000D+03 LocD2 -0.443496D+00 -0.100000D+03 0.100000D+03 ConD1 0.734521D+00 -0.100000D+03 0.100000D+03 ConD2 0.648764D+00 -0.100000D+03 0.100000D+03 BedD1 -0.125812D+01 -0.100000D+03 0.100000D+03 BedD2 -0.641347D+00 -0.100000D+03 0.100000D+03 Htype 0.429202D+00 -0.100000D+03 0.100000D+03 CDum +0.958062D+00 -0.100000D+03 0.100000D+03 Apt3 run 2: Simple trinomial probit model with no exploitation of demographics. (This also works with trinomial probit) Includes an alternative specific dummy for alternative "C" Explanatory data (for Unit 2 input stream) are in APT3ALL.FU2 Gauss-Newton Hessian Leave-Block-Out Regression Diagnostics Block size is fixed, = 27 No. of blocks = 21 No X(I) diagnostics are desired... //GO.SYSIN DD rent1.fu1 cat >rent2.fu1 <<'//GO.SYSIN DD rent2.fu1' 9 567 3 0 -1 27 6 0 2 3 0 3 1 216 162 189 3 9 0 0 0 RENT -0.371499D-02 -0.100000D+03 0.100000D+03 LocD1 0.473069D-01 -0.100000D+03 0.100000D+03 LocD2 -0.443496D+00 -0.100000D+03 0.100000D+03 ConD1 0.734521D+00 -0.100000D+03 0.100000D+03 ConD2 0.648764D+00 -0.100000D+03 0.100000D+03 BedD1 -0.125812D+01 -0.100000D+03 0.100000D+03 BedD2 -0.641347D+00 -0.100000D+03 0.100000D+03 Htype 0.429202D+00 -0.100000D+03 0.100000D+03 CDum +0.958062D+00 -0.100000D+03 0.100000D+03 Apt3 run 2: Simple trinomial probit model with no exploitation of demographics. (This also works with trinomial probit) Includes an alternative specific dummy for alternative "C" Explanatory data (for Unit 2 input stream) are in APT3ALL.FU2 Gauss-Newton Hessian Leave-Block-Out Regression Diagnostics Block size is variable ( = 216, 162, 189) No. of blocks = 3 X(I) diagnostics are desired... //GO.SYSIN DD rent2.fu1 cat >smdc.f0 <<'//GO.SYSIN DD smdc.f0' REAL FUNCTION R7MDC(K) C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C INTEGER K C C *** THE CONSTANT RETURNED DEPENDS ON K... C C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS. C *** K = 2... SQUARE ROOT OF ETA. C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1. C *** K = 4... SQUARE ROOT OF MACHEP. C *** K = 5... SQUARE ROOT OF BIG (SEE K = 6). C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS. C REAL BIG, ETA, MACHEP, ZERO INTEGER BIGI, ETAI, MACHEI EQUIVALENCE (BIG,BIGI), (ETA,ETAI), (MACHEP,MACHEI) PARAMETER (ZERO=0.E+0) C C +++ IEEE ARITHMETIC MACHINES +++ C C DATA BIGI / 2139095039 / C DATA ETAI / 8388608 / C DATA MACHEI / 864026624 / C C +++ IBM, AMDAHL, OR XEROX MAINFRAME +++ C C DATA ETAI / 1048576 / C DATA BIGI / 2147483647 / C DATA MACHEI / 1007681536 / C C +++ VAX +++ C C DATA ETAI / 128 / C DATA BIGI / -32769 / C DATA MACHEI / 13440 / C C +++ CRAY +++ C C DATA BIGI / 6917247552664371198 / C DATA ETAI / 2306828171632181248 / C DATA MACHEI / 4599160381963763712 / C C +++ PORT LIBRARY -- REQUIRES MORE THAN JUST A DATA STATEMENT, +++ C +++ BUT HAS CONSTANTS FOR MANY MORE MACHINES. +++ C C To get the current R1MACH, which has constants for many more C machines, ask netlib@research.att.com to C send r1mach from cor C For machines with rounded arithmetic (e.g., IEEE or VAX arithmetic), C use MACHEP = 0.5 * R1MACH(3) below. C C REAL R1MACH C EXTERNAL R1MACH C DATA BIG/0.E+0/, ETA/0.E+0/, MACHEP/0.E+0/, ZERO/0.E+0/ C IF (BIG .GT. ZERO) GO TO 1 C BIG = R1MACH(2) C ETA = R1MACH(1) C MACHEP = R1MACH(4) C1 CONTINUE C C +++ END OF PORT +++ C C------------------------------- BODY -------------------------------- C C IF (MACHEP .LE. ZERO) THEN WRITE(*,*) 'Edit R7MDC to activate the appropriate statements' STOP 987 ENDIF GO TO (10, 20, 30, 40, 50, 60), K C 10 R7MDC = ETA GO TO 999 C 20 R7MDC = SQRT(256.E+0*ETA)/16.E+0 GO TO 999 C 30 R7MDC = MACHEP GO TO 999 C 40 R7MDC = SQRT(MACHEP) GO TO 999 C 50 R7MDC = SQRT(BIG/256.E+0)*16.E+0 GO TO 999 C 60 R7MDC = BIG C 999 RETURN C *** LAST LINE OF R7MDC FOLLOWS *** END INTEGER FUNCTION I7MDCN(K) C INTEGER K C C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS *** C C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. *** C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. *** C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. *** C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.) C C +++ PORT VERSION FOLLOWS... C INTEGER I1MACH C EXTERNAL I1MACH C INTEGER MDPERM(3) C DATA MDPERM(1)/2/, MDPERM(2)/4/, MDPERM(3)/1/ C I7MDCN = I1MACH(MDPERM(K)) C +++ END OF PORT VERSION +++ C C +++ NON-PORT VERSION FOLLOWS... INTEGER MDCON(3) DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/ I7MDCN = MDCON(K) C +++ END OF NON-PORT VERSION +++ C 999 RETURN C *** LAST LINE OF I7MDCN FOLLOWS *** END //GO.SYSIN DD smdc.f0 cat >sglfg.f <<'//GO.SYSIN DD sglfg.f' SUBROUTINE GLG(N, P, PS, X, RHO, RHOI, RHOR, IV, LIV, LV, V, 1 CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION A LA NL2SOL *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) REAL X(*), RHOR(*), V(LV), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE RGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV, AT LEAST 90 + P. C LV...... LENGTH OF V, AT LEAST C 105 + P*(3*P + 16) + 2*N + 4*PS C + N*(P + 1 + (P-PS+1)*(P-PS+2)/2). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR AND JACOBIAN MATRIX. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED IS AN INTEGER ARRAY OF LENGTH 2... C NEED(1) = 1 MEANS CALCRJ SHOULD COMPUTE THE RESIDUAL VECTOR R, C AND NEED(2) IS THE VALUE NF HAD AT THE LAST X WHERE C CALCRJ MIGHT BE CALLED WITH NEED(1) = 2. C NEED(1) = 2 MEANS CALCRJ SHOULD COMPUTE THE JACOBIAN MATRIX RP, C WHERE RP(J,I) = DERIVATIVE OF R(I) WITH RESPECT TO X(J). C (CALCRJ SHOULD NOT CHANGE NEED AND SHOULD CHANGE AT MOST ONE OF R C AND RP. IF R OR RP, AS APPROPRIATE, CANNOT BE COMPUTED, THEN CALCRJ C SHOULD SET NF TO 0. OTHERWISE IT SHOULD NOT CHANGE NF.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RGLG C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RGLG ... CARRIES OUT OPTIMIZATION ITERATIONS. C C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, I, IV1, NEED1(2), NEED2(2), NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+1+I) CALL RGLG(X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, RHO, RHOI, 1 RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 1)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL RGLG(V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, V(R1), 1 V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 60 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL CALCRJ(N, PS, X, NF, NEED1, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCRJ(N, PS, X, IV(NFGCAL), NEED2, V(R1), V(DR1), UI, UR,UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED C *** AND PRINT IT IF SO REQUESTED... C 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 C 999 RETURN C C *** LAST LINE OF GLG FOLLOWS *** END SUBROUTINE GLF(N, P, PS, X, RHO, RHOI, RHOR, IV, LIV, LV, V, 1 CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION, FINITE-DIFFERENCE JACOBIAN *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) REAL X(*), V(LV), RHOR(*), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE RGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV, AT LEAST 90 + P. C LV...... LENGTH OF V, AT LEAST C 105 + P*(3*P + 16) + 2*N + 4*PS C + N*(P + 3 + (P-PS+1)*(P-PS+2)/2). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED MAY BE REGARDED AS AN INTEGER THAT ALWAYS HAS THE VALUE 1 C WHEN GLF CALLS CALCRJ. THIS MEANS CALCRJ SHOULD COMPUTE THE C RESIDUAL VECTOR R. (CALCRJ SHOULD NOT CHANGE NEED OR RP. IF R C CANNOT BE COMPUTED, THEN CALCRJ SHOULD SET NF TO 0. OTHERWISE IT C SHOULD NOT CHANGE NF. FOR COMPATIBILITY WITH GLG, NEED IS A C VECTOR OF LENGTH 2.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RGLG, V7CPY C C IVSET... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RGLG... CARRIES OUT OPTIMIZATION ITERATIONS. C V7CPY... COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, I1, IV1, J1K, J1K0, K, NEED(2), NF, 1 NG, RD1, R1, R21, RN, RS1 REAL H, H0, HLIM, NEGPT5, ONE, XK, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, RDREQ, REGD, REGD0, TOOBIG, VNEED PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, RDREQ=57, REGD=67, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED DATA HLIM/0.1E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ DATA NEED(1)/1/, NEED(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IF (IV(COVREQ) .EQ. 0 .AND. IV(RDREQ) .GT. 0) IV(COVREQ) = -1 IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+3+I) CALL RGLG(X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, RHO, RHOI, 1 RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 3)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) R21 = RD1 - N RS1 = R21 - N RN = RS1 + N - 1 C 20 CALL RGLG(V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, V(R1), 1 V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 120 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCRJ(N, PS, X, NF, NEED, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 CALL V7CPY(N, V(RS1), V(R1)) IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL V7SCP(P, V(D1), ONE) C DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 J1K0 = DR1 NF = IV(NFCALL) IF (NF .EQ. IV(NFGCAL)) GO TO 70 NG = NG + 1 CALL CALCRJ(N, PS, X, NF, NEED, V(RS1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 70 60 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 70 DO 110 K = 1, PS XK = X(K) H = V(DLTFDJ) * MAX( ABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 80 X(K) = XK + H NG = NG + 1 NF = -NG CALL CALCRJ(N, PS, X, NF, NEED, V(R21), V(DR1), UI, UR, UF) IF (NF .LT. 0) GO TO 90 H = NEGPT5 * H IF ( ABS(H/H0) .GE. HLIM) GO TO 80 GO TO 60 90 X(K) = XK IV(NGCALL) = NG I1 = R21 J1K = J1K0 J1K0 = J1K0 + 1 DO 100 I = RS1, RN V(J1K) = (V(I1) - V(I)) / H I1 = I1 + 1 J1K = J1K + PS 100 CONTINUE 110 CONTINUE GO TO 20 C 120 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 C 999 RETURN C C *** LAST LINE OF GLF FOLLOWS *** END SUBROUTINE RGLG(D, DR, IV, LIV, LV, N, ND, NN, P, PS, R, 1 RD, RHO, RHOI, RHOR, V, X) C C *** ITERATION DRIVER FOR GENERALIZED (NON)LINEAR MODELS (ETC.) C INTEGER LIV, LV, N, ND, NN, P, PS INTEGER IV(LIV), RHOI(*) REAL D(P), DR(ND,N), R(*), RD(*), RHOR(*), 1 V(LV), X(*) C DIMENSION RD(N, (P-PS)*(P-PS+1)/2 + 1) EXTERNAL RHO 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 + 90. C LV...... LENGTH OF V... LV MUST BE AT LEAST C 105 + P*(2*P+16) + 2*N + 4*PS. C N....... TOTAL NUMBER OF RESIDUALS. C ND...... LEADING DIMENSION OF DR -- MUST BE AT LEAST PS. C NN...... LEAD DIMENSION OF R, RD. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS. C R....... RESIDUALS (OR MEANS -- FUNCTIONS OF X) WHEN RGLG IS CALLED C WITH IV(1) = 1. C RD...... RD(I) = HALF * (G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN C IV(RDREQ) IS 2, 3, 5, OR 6. RGLG 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. BEFORE CONVERGENCE, RD IS ALSO USED AS C TEMPORARY STORAGE. C RHO..... COMPUTES INFO ABOUT OBJECTIVE FUNCTION. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C V....... FLOATING-POINT VALUES ARRAY. C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** CALLING SEQUENCE FOR RHO... C C CALL RHO(NEED, F, N, NF, XN, R, RD, RHOI, RHOR, W) C C PARAMETER DECLARATIONS FOR RHO... C C INTEGER NEED(2), N, NF, RHOI(*) C FLOATING-POINT F, XN(*), R(*), RD(N,*), RHOR(*), W(N) C C RHOI AND RHOR ARE FOR RHO TO USE AS IT SEES FIT. THEY ARE PASSED C TO RHO WITHOUT CHANGE. IF IV(RDREQ) IS AT LEAST 4, I.E., IF MORE C THAN THE SIMPLEST REGRESSION DIAGNOSTIC INFORMATION IS TO BE COMPUTED, C THEN SOME COMPONENTS OF RHOI AND RHOR MUST CONVEY SOME EXTRA C DETAILS, AS DESCRIBED BELOW. C F, R, RD, AND W ARE EXPLAINED BELOW WITH NEED. C XN IS THE VECTOR OF NUISANCE PARAMETERS (OF LENGTH P - PS). IF C RHO NEEDS TO KNOW THE LENGTH OF XN, THEN THIS LENGTH SHOULD BE C COMMUNICATED THROUGH RHOI (OR THROUGH COMMON). RHO SHOULD NOT CHANGE C XN. C NEED(1) = 1 MEANS RHO SHOULD SET F TO THE SUM OF THE LOSS FUNCTION C VALUES AT THE RESIDUALS R(I). NF IS THE CURRENT FUNCTION INVOCATION C COUNT (A VALUE THAT IS INCREMENTED EACH TIME A NEW PARAMETER EXTIMATE C X IS CONSIDERED). NEED(2) IS THE VALUE NF HAD AT THE LAST R WHERE C RHO MIGHT BE CALLED WITH NEED(1) = 2. IF RHO SAVES INTERMEDIATE C RESULTS FOR USE IN CALLS WITH NEED(1) = 2, THEN IT CAN USE NF TO TELL C WHICH INTERMEDIATE RESULTS ARE APPROPRIATE, AND IT CAN SAVE SOME OF C THESE RESULTS IN R. C NEED(1) = 2 MEANS RHO SHOULD SET R(I) TO THE LOSS FUNCTION C DERIVATIVE WITH RESPECT TO THE RESIDUALS THAT WERE PASSED TO RHO WHEN C NF HAD THE SAME VALUE IT DOES NOW (AND NEED(1) WAS 1). RHO SHOULD C ALSO SET W(I) TO THE APPROXIMATION OF THE SECOND DERIVATIVE OF THE C LOSS FUNCTION (WITH RESPECT TO THE I-TH RESIDUAL) THAT SHOULD BE USED C IN THE GAUSS-NEWTON MODEL. WHEN THERE ARE NUISANCE PARAMETERS (I.E., C WHEN PS .LT. P) RHO SHOULD ALSO SET R(I+K*N) TO THE DERIVATIVE OF THE C LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL AND XN(K), AND IT C SHOULD SET RD(I,J + K*(K+1)/2 + 1) TO THE SECOND PARTIAL DERIVATIVE C OF THE I-TH RESIDUAL WITH RESPECT TO XN(J) AND XN(K), 0 .LE. J .LE. K C AND 1 .LE. K .LE. P - PS, WHERE XN(0) MEANS THE I-TH RESIDUAL ITSELF. C IN ANY EVENT, RHO SHOULD ALSO SET RD(I,1) TO THE (TRUE) SECOND C DERIVATIVE OF THE LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL. C NF (THE FUNCTION INVOCATION COUNT WHOSE NORMAL USE IS EXPLAINED C ABOVE) SHOULD NOT BE CHANGED UNLESS RHO CANNOT CARRY OUT THE REQUESTED C TASK, IN WHICH CASE RHO SHOULD SET NF TO 0. C C C *** REGRESSION DIAGNOSTICS *** C C IV(RDREQ) INDICATES WHETHER A COVARIANCE MATRIX AND REGRESSION C DIAGNOSTIC VECTOR ARE TO BE COMPUTED. IV(RDREQ) HAS THE FORM C IV(RDREQ) = CVR +2*RDR, WHERE CVR = 0 OR 1 AND RDR = 0, 1, OR 2, C SO THAT C C CVR = MOD(IV(RDREQ), 2) C RDR = MOD(IV(RDREQ)/2, 3). C C CVR = 0 FOR NO COVARIANCE MATRIX C = 1 IF A COVARIANCE MATRIX ESTIMATE IS DESIRED C C RDR = 0 FOR NO LEAVE-ONE-OUT DIAGNOSTIC INFORMATION. C = 1 TO HAVE ONE-STEP ESTIMATES OF F(X(I)) - F(X*) STORED IN RD, C WHERE X(I) MINIMIZES F (THE OBJECTIVE FUNCTION) WITH C COMPONENT I OF R REMOVED AND X* MINIMIZES THE FULL F. C = 2 FOR MORE DETAILED ONE-STEP LEAVE-ONE-OUT INFORMATION, AS C DICTATED BY THE IV COMPONENTS DESCRIBED BELOW. C C FOR RDR = 2, THE FOLLOWING COMPONENTS OF IV ARE RELEVANT... C C NFIX = IV(83) = NUMBER OF TRAILING NUISANCE PARAMETERS TO TREAT C AS FIXED WHEN COMPUTING DIAGNOSTIC VECTORS (0 .LE. NFIX .LE. C P - PS, SO X(I) IS KEPT FIXED FOR P - NFIX .LT. I .LE. P). C C LOO = IV(84) TELLS WHAT TO LEAVE OUT... C = 1 MEANS LEAVE OUT EACH COMPONENT OF R SEPARATELY, AND C = 2 MEANS LEAVE OUT CONTIGUOUS BLOCKS OF R COMPONENTS. C FOR LOO = 2, IV(85) IS THE STARTING SUBSCRIPT IN RHOI C OF AN ARRAY BS OF BLOCK SIZES, IV(86) IS THE STRIDE FOR BS, C AND IV(87) = NB IS THE NUMBER OF BLOCKS, SO THAT C BS(I) = RHOI(IV(85) + (I-1)*IV(86)), 1 .LE. I .LE. NB. C NOTE THAT IF ALL BLOCKS ARE THE SAME SIZE, THEN IT SUFFICES C TO SET RHOI(IV(85)) = BLOCKSIZE AND IV(86) = 0. C NOTE THAT LOO = 1 IS EQUIVALENT TO LOO = 2 WITH C RHOI(IV(85)) = 1, IV(86) = 0, IV(87) = N. C = 3,4 ARE SIMILAR TO LOO = 1,2, RESPECTIVELY, BUT LEAVING A C FRACTION OUT. IN THIS CASE, IV(88) IS THE STARTING C SUBSCRIPT IN RHOR OF AN ARRAY FLO OF FRACTIONS TO LEAVE OUT, C AND IV(89) IS THE STRIDE FOR FLO... C FLO(I) = RHOR(IV(88) + (I-1)*IV(89)), 1 .LE. I .LE. NB. C C XNOTI = IV(90) TELLS WHAT DIAGNOSTIC INFORMATION TO STORE... C = 0 MEANS JUST STORE ONE-STEP ESTIMATES OF F(X(I)) - F(X*) IN C RD(I), 1 .LE. I .LE. NB. C .GT. 0 MEANS ALSO STORE ONE-STEP ESTIMATES OF X(I) ESTIMATES C IN RHOR, STARTING AT RHOR(XNOTI)... C X(I)(J) = RHOR((I-1)*(P-NFIX) + J + XNOTI-1), C 1 .LE. I .LE. NB, 1 .LE. J .LE. P - NFIX. C C SOMETIMES ONE-STEP ESTIMATES OF X(I) DO NOT EXIST, BECAUSE THE C APPROXIMATE UPDATED HESSIAN MATRIX IS INDEFINITE. IN SUCH CASES, C THE CORRESPONDING RD COMPONENT IS SET TO -1, AND, IF XNOTI IS C POSITIVE, THE SOLUTION X IS RETURNED AS X(I). WHEN ONE-STEP ESTIMATES C OF X(I) DO EXIST, THE CORRESPONDING COMPONENT OF RD IS POSITIVE. C C SUMMARY OF RHOI COMPONENTS (FOR RDR = MOD(IV(RDREQ)/2, 3) = 2)... C C IV(83) = NFIX C IV(84) = LOO C IV(85) = START IN RHOI OF BS C IV(86) = STRIDE FOR BS C IV(87) = NB C IV(88) = START IN RHOR OF FLO C IV(89) = STRIDE FOR FLO C IV(90) = XNOTI (START IN RHOR OF X(I)). C C C *** COVARIANCE MATRIX ESTIMATE *** C C IF IV(RDREQ) INDICATES THAT A COVARIANCE MATRIX IS TO BE COMPUTED, C THEN IV(COVREQ) = IV(15) DETERMINES THE FORM OF THE COMPUTED C COVARIANCE MATRIX ESTIMATE AND, SIMULTANEOUSLY, THE FORM OF C APPROXIMATE HESSIAN MATRIX USED IN COMPUTING REGRESSION DIAGNOSTIC C INFORMATION. IN ALL CASES, SOME APPROXIMATE FINAL HESSIAN MATRIX C IS OBTAINED, AND ITS INVERSE IS THE COVARIANCE MATRIX ESTIMATE C (WHICH MAY HAVE TO BE SCALED APPROPRIATELY -- THAT IS UP TO YOU). C IF IV(COVREQ) IS AT MOST 2 IN ABSOLUTE VALUE, THEN THE FINAL C HESSIAN APPROXIMATION IS COMPUTED BY FINITE DIFFERENCES -- GRADIENT C DIFFERENCES IF IV(COVREQ) IS NONNEGATIVE, FUNCTION DIFFERENCES C OTHERWISE. IF (IV(COVREQ)) IS AT LEAST 3 IN ABSOLUTE VALUE, THEN THE C CURRENT GAUSS-NEWTON HESSIAN APPROXIMATION IS TAKEN AS THE FINAL C HESSIAN APPROXIMATION. FOR SOME PROBLEMS THIS SAVES TIME AND YIELDS C THE SAME OR NEARLY THE SAME HESSIAN APPROXIMATION AS DO FINITE C DIFFERENCES. FOR OTHER PROBLEMS, THE TWO KINDS OF HESSIAN C APPROXIMATIONS MAY GIVE DECIDEDLY DIFFERENT REGRESSION DIAGNOSTICS AND C COVARIANCE MATRIX ESTIMATES. C C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL D7UP5, IVSET, G2LRD, N3RDP, D7TPR, Q7ADR, VSUM, 1 G7LIT, ITSUM, L7NVR, L7ITV, L7IVM, L7SRT, L7SQR, 2 L7SVX, L7SVN, L7TSQ, L7VML, O7PRD, V2AXY, V7CPY, 3 V7SCL, V7SCP REAL D7TPR, L7SVX, L7SVN, VSUM C C D7UP5... UPDATES SCALE VECTOR D. C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C G2LRD.... COMPUTES REGRESSION DIAGNOSTIC. C N3RDP... PRINTS REGRESSION DIAGNOSTIC. C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C Q7ADR.... ADDS ROWS TO QR FACTORIZATION. C VSUM..... RETURNS SUM OF ELEMENTS OF A VECTOR. C G7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM. C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C L7NVR... INVERTS COMPACTLY STORED TRIANGULAR MATRIX. C L7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C L7IVM... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C L7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C L7SQR... COMPUTES L*(L**T) FOR LOWER TRIANG. MATRIX L. C L7SVX... UNDERESTIMATES LARGEST SINGULAR VALUE OF TRIANG. MATRIX. C L7SVN... OVERESTIMATES SMALLEST SINGULAR VALUE OF TRIANG. MATRIX. C L7TSQ... COMPUTES (L**T)*L FOR LOWER TRIANG. MATRIX L. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C O7PRD.... ADDS OUTER PRODUCT OF VECTORS TO A MATRIX. C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCL... MULTIPLIES A VECTOR BY A SCALAR. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C LOGICAL JUSTG, UPDATD, ZEROG INTEGER G1, HN1, I, II, IV1, J, J1, JTOL1, K, L, LH, 1 NEED1(2), NEED2(2), PMPS, PS1, PSLEN, QTR1, 2 RMAT1, STEP1, TEMP1, TEMP2, TEMP3, TEMP4, W, WI, Y1 REAL RHMAX, RHTOL, RHO1, RHO2, T C REAL ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COVMAT, DINIT, DTYPE, DTINIT, D0INIT, F, 1 F0, FDH, G, H, HC, IPIVOT, IVNEED, JCN, JTOL, LMAT, 2 MODE, NEXTIV, NEXTV, NF0, NF1, NFCALL, NFCOV, NFGCAL, 3 NGCALL, NGCOV, PERM, QTR, RDREQ, REGD, RESTOR, 4 RMAT, RSPTOL, STEP, TOOBIG, VNEED, XNOTI, Y C C *** IV SUBSCRIPT VALUES *** C PARAMETER (CNVCOD=55, COVMAT=26, DTYPE=16, F0=13, FDH=74, G=28, 1 H=56, HC=71, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59, 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6, 3 NFCOV=52, NF0=68, NF1=69, NFGCAL=7, NGCALL=30, 4 NGCOV=53, PERM=58, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, 5 REGD=67, STEP=40, TOOBIG=2, VNEED=4, XNOTI=90, Y=48) C C *** V SUBSCRIPT VALUES *** C PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RSPTOL=49) PARAMETER (ONE=1.E+0, ZERO=0.E+0) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) PS1 = PS + 1 IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 W = IV(Y) + P IV(RESTOR) = 0 I = IV1 + 2 IF (IV(TOOBIG) .EQ. 0) GO TO (120, 110, 110, 130), I V(F) = V(F0) IF (I .NE. 3) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LT. PS) GO TO 360 IF (PS .GT. P) GO TO 360 IF (PS .LE. 0) GO TO 360 IF (N .LE. 0) GO TO 360 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 420 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 + 2*N + 4*PS C *** ADJUST IV(PERM) TO MAKE ROOM FOR IV INPUT COMPONENTS C *** NEEDED WHEN IV(RDREQ) IS 4 OR 5... I = XNOTI + 1 IF (IV(PERM) .LT. I) IV(PERM) = I C 20 CALL G7LIT(D, X, IV, LIV, LV, P, PS, 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 + N IV(RMAT) = IV(G) + P + 4*PS IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + P + N IV(JCN) = IV(JTOL) + 2*P IV(NEXTV) = IV(JCN) + P IF (IV1 .EQ. 13) GO TO 999 C 30 JTOL1 = IV(JTOL) IF (V(DINIT) .GE. ZERO) CALL V7SCP(P, D, V(DINIT)) IF (V(DTINIT) .GT. ZERO) CALL V7SCP(P, V(JTOL1), V(DTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL V7SCP(P, V(I), V(D0INIT)) IV(NF0) = 0 IV(NF1) = 0 C 40 G1 = IV(G) Y1 = IV(Y) CALL G7LIT(D, V(G1), IV, LIV, LV, P, PS, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 380 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 999 IF (IV(RESTOR) .NE. 2) GO TO 999 IV(NF0) = IV(NF1) CALL V7CPY(N, RD, R) IV(REGD) = 0 GO TO 999 C 60 IF (IV(MODE) .GT. 0) GO TO 370 CALL V7SCP(P, V(G1), ZERO) RMAT1 = IABS(IV(RMAT)) QTR1 = IABS(IV(QTR)) CALL V7SCP(PS, V(QTR1), ZERO) IV(REGD) = 0 CALL V7SCP(PS, V(Y1), ZERO) CALL V7SCP(LH, V(RMAT1), ZERO) IF (IV(RESTOR) .NE. 3) GO TO 70 CALL V7CPY(N, R, RD) IV(NF1) = IV(NF0) 70 CALL RHO(NEED2, T, N, IV(NFGCAL), X(PS1), R, RD, RHOI, RHOR, V(W)) IF (IV(NFGCAL) .GT. 0) GO TO 90 80 IV(TOOBIG) = 1 GO TO 40 90 IF (IV(MODE) .LT. 0) GO TO 999 DO 100 I = 1, N 100 CALL V2AXY(PS, V(Y1), R(I), DR(1,I), V(Y1)) GO TO 999 C C *** COMPUTE F(X) *** C 110 I = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL RHO(NEED1, V(F), N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IV(NF1) = I IF (I .LE. 0) GO TO 80 GO TO 40 C C *** COMPUTE GRADIENT INFORMATION FOR FINITE-DIFFERENCE HESSIAN *** C 120 IV(1) = 2 JUSTG = .TRUE. I = IV(NFCALL) CALL RHO(NEED1, T, N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IF (I .LE. 0) GO TO 80 CALL RHO(NEED2, T, N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IF (I .LE. 0) GO TO 80 GO TO 250 C C *** PREPARE TO COMPUTE GRADIENT INFORMATION WHILE ITERATING *** C 130 JUSTG = .FALSE. G1 = IV(G) C C *** DECIDE WHETHER TO UPDATE D BELOW *** C I = IV(DTYPE) UPDATD = .FALSE. IF (I .LE. 0) GO TO 140 IF (I .EQ. 1 .OR. IV(MODE) .LT. 0) UPDATD = .TRUE. C C *** COMPUTE RMAT AND QTR *** C 140 QTR1 = IABS(IV(QTR)) RMAT1 = IABS(IV(RMAT)) IV(RMAT) = RMAT1 IV(HC) = 0 IV(NF0) = 0 IV(NF1) = 0 IF (IV(MODE) .LT. 0) GO TO 160 C C *** ADJUST Y *** C Y1 = IV(Y) WI = W STEP1 = IV(STEP) DO 150 I = 1, N T = V(WI) - RD(I) WI = WI + 1 IF (T .NE. ZERO) CALL V2AXY(PS, V(Y1), 1 T* D7TPR(PS,V(STEP1),DR(1,I)), DR(1,I), V(Y1)) 150 CONTINUE C C *** CHECK FOR NEGATIVE W COMPONENTS *** C 160 J1 = W + N - 1 DO 170 WI = W, J1 IF (V(WI) .LT. ZERO) GO TO 240 170 CONTINUE C C *** W IS NONNEGATIVE. COMPUTE QR FACTORIZATION *** C *** AND, IF NECESSARY, USE SEMINORMAL EQUATIONS *** C RHMAX = ZERO RHTOL = V(RSPTOL) TEMP1 = G1 + P ZEROG = .TRUE. WI = W DO 200 I = 1, N RHO1 = R(I) RHO2 = V(WI) WI = WI + 1 T = SQRT(RHO2) IF (RHMAX .LT. RHO2) RHMAX = RHO2 IF (RHO2 .GT. RHTOL*RHMAX) GO TO 180 C *** SEMINORMAL EQUATIONS *** CALL V2AXY(PS, V(G1), RHO1, DR(1,I), V(G1)) RHO1 = ZERO ZEROG = .FALSE. GO TO 190 180 RHO1 = RHO1 / T C *** QR ACCUMULATION *** 190 CALL V7SCL(PS, V(TEMP1), T, DR(1,I)) CALL Q7ADR(PS, V(QTR1), V(RMAT1), V(TEMP1), RHO1) 200 CONTINUE C C *** COMPUTE G FROM RMAT AND QTR *** C TEMP2 = TEMP1 + PS CALL L7VML(PS, V(TEMP1), V(RMAT1), V(QTR1)) IF (ZEROG) GO TO 220 IV(QTR) = -QTR1 IF ( L7SVX(PS, V(RMAT1), V(TEMP2), V(TEMP2)) * RHTOL .GE. 1 L7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2))) GO TO 230 CALL L7IVM(PS, V(TEMP2), V(RMAT1), V(G1)) C C *** SEMINORMAL EQUATIONS CORRECTION OF BJOERCK -- C *** ONE CYCLE OF ITERATIVE REFINEMENT... C TEMP3 = TEMP2 + PS TEMP4 = TEMP3 + PS CALL L7ITV(PS, V(TEMP3), V(RMAT1), V(TEMP2)) CALL V7SCP(PS, V(TEMP4), ZERO) RHMAX = ZERO WI = W DO 210 I = 1, N RHO2 = V(WI) WI = WI + 1 IF (RHMAX .LT. RHO2) RHMAX = RHO2 RHO1 = ZERO IF (RHO2 .LE. RHTOL*RHMAX) RHO1 = R(I) T = RHO1 - RHO2* D7TPR(PS, V(TEMP3), DR(1,I)) CALL V2AXY(PS, V(TEMP4), T, DR(1,I), V(TEMP4)) 210 CONTINUE CALL L7IVM(PS, V(TEMP3), V(RMAT1), V(TEMP4)) CALL V2AXY(PS, V(TEMP2), ONE, V(TEMP3), V(TEMP2)) CALL V2AXY(PS, V(QTR1), ONE, V(TEMP2), V(QTR1)) 220 IV(QTR) = QTR1 230 CALL V2AXY(PS, V(G1), ONE, V(TEMP1), V(G1)) IF (PS .GE. P) GO TO 350 GO TO 270 C C *** INDEFINITE GN HESSIAN... *** C 240 IV(RMAT) = -RMAT1 IV(HC) = RMAT1 CALL O7PRD(N, LH, PS, V(RMAT1), V(W), DR, DR) C C *** COMPUTE GRADIENT *** C 250 G1 = IV(G) CALL V7SCP(P, V(G1), ZERO) DO 260 I = 1, N 260 CALL V2AXY(PS, V(G1), R(I), DR(1,I), V(G1)) IF (PS .GE. P) GO TO 350 C C *** COMPUTE GRADIENT COMPONENTS OF NUISANCE PARAMETERS *** C 270 K = P - PS J1 = 1 G1 = G1 + PS DO 280 J = 1, K J1 = J1 + NN V(G1) = VSUM(N, R(J1)) G1 = G1 + 1 280 CONTINUE IF (JUSTG) GO TO 390 C C *** COMPUTE HESSIAN COMPONENTS OF NUISANCE PARAMETERS *** C I = PS*PS1/2 PSLEN = P*(P+1)/2 - I HN1 = RMAT1 + I CALL V7SCP(PSLEN, V(HN1), ZERO) PMPS = P - PS K = HN1 J1 = 1 DO 310 II = 1, PMPS J1 = J1 + NN J = J1 DO 290 I = 1, N CALL V2AXY(PS, V(K), RD(J), DR(1,I), V(K)) J = J + 1 290 CONTINUE K = K + PS DO 300 I = 1, II J1 = J1 + NN V(K) = VSUM(N, RD(J1)) K = K + 1 300 CONTINUE 310 CONTINUE IF (IV(RMAT) .LE. 0) GO TO 350 J = IV(LMAT) CALL V7CPY(PSLEN, V(J), V(HN1)) IF ( L7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2)) .LE. ZERO) GO TO 320 CALL L7SRT(PS1, P, V(RMAT1), V(RMAT1), I) IF (I .LE. 0) GO TO 330 C C *** HESSIAN IS NOT POSITIVE DEFINITE *** C 320 CALL L7SQR(PS, V(RMAT1), V(RMAT1)) CALL V7CPY(PSLEN, V(HN1), V(J)) IV(HC) = RMAT1 IV(RMAT) = -RMAT1 GO TO 350 C C *** NUISANCE PARS LEAVE HESSIAN POS. DEF. GET REST OF QTR *** C 330 J = QTR1 + PS G1 = IV(G) + PS DO 340 I = PS1, P T = D7TPR(I-1, V(HN1), V(QTR1)) HN1 = HN1 + I V(J) = (V(G1) - T) / V(HN1-1) J = J + 1 G1 = G1 + 1 340 CONTINUE 350 IF (JUSTG) GO TO 390 IF (UPDATD) CALL D7UP5(D, IV, LIV, LV, P, PS, V) GO TO 40 C C *** MISC. DETAILS *** C C *** BAD N, ND, OR P *** C 360 IV(1) = 66 GO TO 420 C C *** COVARIANCE OR INITIAL S COMPUTATION *** C 370 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 GO TO 999 C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 380 IF (IV(COVMAT) .NE. 0) GO TO 410 IF (IV(REGD) .NE. 0) GO TO 410 C C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE *** C K = IV(FDH) IF (K .LE. 0) GO TO 400 IF (IV(RDREQ) .LE. 0) GO TO 410 C C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF C DESIRED *** C IV(MODE) = P + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NGCOV) = IV(NGCOV) + 1 IV(CNVCOD) = IV(1) IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(NFGCAL) = IV(NFCALL) IV(1) = -1 GO TO 999 C 390 IF (IV(MODE) .LE. P) GO TO 40 C *** SAVE RD IN W FOR POSSIBLE USE IN OTHER DIAGNOSTICS *** CALL V7CPY(N, V(W), RD) C *** OVERWRITE RD WITH REGRESSION DIAGNOSTICS *** L = IV(LMAT) I = IV(JCN) STEP1 = IV(STEP) CALL G2LRD(DR, IV, V(L), LH, LIV, LV, ND, N, P, PS, R, RD, 1 RHOI, RHOR, V, V(STEP1), X, V(I)) IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 IF (MOD(IV(RDREQ),2) .EQ. 0) GO TO 410 C C *** FINISH COVARIANCE COMPUTATION *** C I = IABS(IV(H)) IV(FDH) = 0 CALL L7NVR(P, V(I), V(L)) CALL L7TSQ(P, V(I), V(I)) IV(COVMAT) = I GO TO 410 C C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN *** C 400 IV(COVMAT) = K IV(REGD) = K C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 410 G1 = IV(G) 420 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X) IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0) 1 CALL N3RDP(IV, LIV, LV, N, P, RD, RHOI, RHOR, V) C 999 RETURN C *** LAST LINE OF RGLG FOLLOWS *** END SUBROUTINE F7HES(D, G, IRT, IV, LIV, LV, P, V, X) C C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING C *** AT V(IV(FDH)) = V(-IV(H)). C C *** IF IV(COVREQ) .GE. 0 THEN F7HES USES GRADIENT DIFFERENCES, C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN G7LIT. C C IRT VALUES... C 1 = COMPUTE FUNCTION VALUE, I.E., V(F). C 2 = COMPUTE G. C 3 = DONE. C C C *** PARAMETER DECLARATIONS *** C INTEGER IRT, LIV, LV, P INTEGER IV(LIV) REAL D(P), G(P), V(LV), X(P) C C *** LOCAL VARIABLES *** C INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2, 1 PP1O2, STPI, STPM, STP0 REAL DEL, HALF, NEGPT5, ONE, TWO, ZERO C C *** EXTERNAL SUBROUTINES *** C EXTERNAL V7CPY C C V7CPY.... COPY ONE VECTOR TO ANOTHER. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE, 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE C PARAMETER (HALF=0.5E+0, NEGPT5=-0.5E+0, ONE=1.E+0, TWO=2.E+0, 1 ZERO=0.E+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 F7HES. SET GSAVE = G, TAKE FIRST STEP *** CALL V7CPY(P, V(GSAVE1), G) IV(SWITCH) = IV(NFGCAL) GO TO 90 C 20 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 40 C C *** HANDLE OVERSIZE V(DELTA) *** C IF (DEL*X(M) .GT. ZERO) GO TO 30 C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT *** IV(FDH) = -2 GO TO 220 C C *** TRY SHRINKING V(DELTA) *** 30 DEL = NEGPT5 * DEL GO TO 100 C 40 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DO 50 I = 1, P G(I) = (G(I) - V(GSAVE1)) / DEL GSAVE1 = GSAVE1 + 1 50 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 70 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 60 I = 1, MM1 V(K) = HALF * (V(K) + G(I)) K = K + 1 60 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 70 L = L + 1 DO 80 I = M, P V(L) = G(I) L = L + I 80 CONTINUE C 90 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 210 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * MAX(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 100 X(M) = X(M) + DEL V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 110 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 120 C *** FIRST CALL ON F7HES. *** IV(SAVEI) = 0 GO TO 200 C 120 I = IV(SAVEI) HES = -IV(H) IF (I .GT. 0) GO TO 180 IF (IV(TOOBIG) .EQ. 0) GO TO 140 C C *** HANDLE OVERSIZE STEP *** C STPM = STP0 + M DEL = V(STPM) IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 130 C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT *** IV(FDH) = -2 GO TO 220 C C *** TRY SHRINKING THE STEP *** 130 DEL = NEGPT5 * DEL X(M) = X(XMSAVE) + DEL V(STPM) = DEL IRT = 1 GO TO 999 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C 140 PP1O2 = P * (P-1) / 2 HPM = HES + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C HMI = HES + MM1O2 IF (MM1 .EQ. 0) GO TO 160 HPI = HES + PP1O2 DO 150 I = 1, MM1 V(HMI) = V(FX) - (V(F) + V(HPI)) HMI = HMI + 1 HPI = HPI + 1 150 CONTINUE 160 V(HMI) = V(F) - TWO*V(FX) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 1 C 170 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI) IRT = 1 GO TO 999 C 180 X(I) = V(DELTA) IF (IV(TOOBIG) .EQ. 0) GO TO 190 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** IV(FDH) = -2 GO TO 220 C C *** FINISH COMPUTING H(M,I) *** C 190 STPI = STP0 + I HMI = HES + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) I = I + 1 IF (I .LE. M) GO TO 170 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 200 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 210 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C DEL = V(DLTFDC) * MAX(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** RESTORE V(F), ETC. *** C 210 IV(FDH) = HES 220 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL V7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST LINE OF F7HES FOLLOWS *** END SUBROUTINE G2LRD(DR, IV, L, LH, LIV, LV, ND, N, P, PS, R, RD, 1 RHOI, RHOR, V, W, X, Z) C C *** COMPUTE REGRESSION DIAGNOSTIC FOR RGLG *** C C *** PARAMETERS *** C INTEGER LH, LIV, LV, ND, N, P, PS INTEGER IV(LIV), RHOI(*) REAL DR(ND,P), L(LH), R(N), RD(N), RHOR(*), V(LV), 1 W(P), X(P), Z(P) C C *** CODED BY DAVID M. GAY (SPRING 1986, SUMMER 1991) *** C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL D7TPR, L7ITV, L7IVM, L7SRT, L7SQR, S7LVM, 1 V2AXY, V7CPY, V7SCP REAL D7TPR C C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C L7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C L7IVM... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C L7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C L7SQR... COMPUTES L*(L**T) FOR LOWER TRIANG. MATRIX L. C S7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR. C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** LOCAL VARIABLES *** C LOGICAL USEFLO INTEGER BS1, BSINC, FLO1, FLOINC, H1, HPS1, I, 1 J, J1, K, KI, KI1, KID, L1, LE, LL, LOO1, N1, 2 PMPS, PP1O2, PS1, PX, RDR, XNI, ZAP1, ZAPLEN REAL FRAC, HI, RI, S, T, T1 C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ZERO C C C *** IV SUBSCRIPTS *** C INTEGER BS, BSSTR, COVREQ, FDH, FLO, FLOSTR, LOO, NB, NFIX, 1 RDREQ, REGD, XNOTI PARAMETER (BS=85, BSSTR=86, COVREQ=15, FDH=74, FLO=88, FLOSTR=89, 1 LOO=84, NB=87, NFIX=83, RDREQ=57, REGD=67, XNOTI=90) PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ZERO=0.E+0) C C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++ C I = IV(RDREQ) RDR = MOD(I/2, 3) IF (RDR .EQ. 0) GO TO 999 H1 = IV(FDH) USEFLO = .FALSE. PX = P N1 = N FRAC = ONE XNI = 0 IF (RDR .EQ. 1) GO TO 120 LOO1 = IV(LOO) IF (LOO1 .LE. 0 .OR. LOO1 .GT. 6) THEN IV(REGD) = -1 GO TO 999 ENDIF IF (LOO1 .GT. 3) THEN USEFLO = .TRUE. FLO1 = IV(FLO) FLOINC = IV(FLOSTR) LOO1 = LOO1 - 3 ENDIF XNI = IV(XNOTI) PX = P - IV(NFIX) IF (PX .LT. PS .OR. PX .GT. P) THEN IV(REGD) = -2 GO TO 999 ENDIF IF (LOO1 .EQ. 1) GO TO 120 N1 = IV(NB) IF (N1 .LE. 0 .OR. N1 .GT. N) THEN IV(REGD) = -3 GO TO 999 ENDIF BS1 = IV(BS) BSINC = IV(BSSTR) IF (H1 .LE. 0) GO TO 190 IF (IABS(IV(COVREQ)) .GE. 3) CALL L7SQR(P, V(H1), L) PP1O2 = PX*(PX+1)/2 PS1 = PS + 1 ZAP1 = PS*(PS1)/2 + 1 LE = 0 DO 100 I = 1, N1 IF (USEFLO) THEN FRAC = RHOR(FLO1) FLO1 = FLO1 + FLOINC ENDIF L1 = LE + 1 IF (L1 .GT. N) GO TO 110 LE = LE + RHOI(BS1) IF (LE .GT. N) LE = N BS1 = BS1 + BSINC CALL V7CPY(PP1O2, L, V(H1)) IF (PS .GE. PX) GO TO 50 K = ZAP1 KI = L1 DO 40 J = PS1, P KI = KI + N KI1 = KI DO 10 LL = L1, LE CALL V2AXY(PS, L(K), -FRAC*RD(KI1), DR(1,LL), L(K)) KI1 = KI1 + 1 10 CONTINUE K = K + PS DO 30 J1 = PS1, J KI = KI + N KI1 = KI T = ZERO DO 20 LL = L1, LE T = T + RD(KI1) KI1 = KI1 + 1 20 CONTINUE L(K) = L(K) - FRAC*T K = K + 1 30 CONTINUE 40 CONTINUE 50 DO 70 LL = L1, LE T = -FRAC*RD(LL) K = 1 DO 60 J = 1, PS CALL V2AXY(J, L(K), T*DR(J,LL), DR(1,LL), L(K)) K = K + J 60 CONTINUE 70 CONTINUE CALL L7SRT(1, PX, L, L, J) IF (J .EQ. 0) THEN CALL V7SCP(PX, W, ZERO) DO 90 LL = L1, LE CALL V2AXY(PS, W, R(LL), DR(1,LL), W) IF (PS1 .GT. PX) GO TO 90 K = L1 DO 80 J = PS1, P K = K + N W(J) = W(J) + R(K) 80 CONTINUE 90 CONTINUE CALL L7IVM(PX, W, L, W) CALL L7ITV(PX, W, L, W) CALL S7LVM(PX, Z, V(H1), W) RD(I) = HALF * FRAC * D7TPR(PX, W, Z) IF (XNI .GT. 0) THEN CALL V2AXY(PX, RHOR(XNI), FRAC, W, X) XNI = XNI + PX ENDIF ELSE RD(I) = NEGONE IF (XNI .GT. 0) THEN CALL V7CPY(PX, RHOR(XNI), X) XNI = XNI + PX ENDIF ENDIF 100 CONTINUE 110 IV(REGD) = 1 C *** RESTORE L *** CALL L7SRT(1, P, L, V(H1), J) GO TO 999 C 120 IF (H1 .LE. 0) GO TO 190 IF (IABS(IV(COVREQ)) .GE. 3) CALL L7SQR(P, V(H1), L) IF (PS .GE. PX) GO TO 170 PS1 = PS + 1 PMPS = PX - PS ZAP1 = PS*(PS1)/2 ZAPLEN = PX*(PX+1)/2 - ZAP1 HPS1 = H1 + ZAP1 ZAP1 = ZAP1 + 1 DO 160 I = 1, N IF (USEFLO) THEN FRAC = RHOR(FLO1) FLO1 = FLO1 + FLOINC ENDIF CALL V7CPY(ZAPLEN, L(ZAP1), V(HPS1)) CALL V7SCP(PS, W, ZERO) K = ZAP1 KI = I KID = KI DO 140 J = PS1, PX KI = KI + N CALL V2AXY(PS, L(K), -FRAC*RD(KI), DR(1,I), L(K)) K = K + PS KID = KID + N W(J) = FRAC*R(KID) DO 130 J1 = PS1, J KI = KI + N L(K) = L(K) - FRAC*RD(KI) K = K + 1 130 CONTINUE 140 CONTINUE CALL L7SRT(PS1, PX, L, L, J) IF (J .NE. 0) GO TO 150 CALL V7CPY(PS, Z, DR(1,I)) CALL V7SCP(PMPS, Z(PS1), ZERO) CALL L7IVM(PX, Z, L, Z) HI = D7TPR(PX, Z, Z) CALL L7IVM(PX, W, L, W) RI = FRAC*R(I) C *** FIRST PS ELEMENTS OF W VANISH *** T = D7TPR(PMPS, W(PS1), Z(PS1)) S = FRAC*RD(I) T1 = ONE - S*HI IF (T1 .LE. ZERO) GO TO 150 CALL V2AXY(PX, W, (RI + S*T)/T1, Z, W) CALL L7ITV(PX, W, L, W) CALL S7LVM(PX, Z, V(H1), W) RD(I) = HALF * D7TPR(PX, W, Z) IF (XNI .GT. 0) THEN CALL V2AXY(PX, RHOR(XNI), ONE, W, X) XNI = XNI + PX ENDIF GO TO 160 150 RD(I) = NEGONE IF (XNI .GT. 0) THEN CALL V7CPY(PX, RHOR(XNI), X) XNI = XNI + PX ENDIF 160 CONTINUE C C *** RESTORE L *** C CALL V7CPY(ZAPLEN, L(ZAP1), V(HPS1)) CALL L7SRT(PS1, PX, L, L, J) GO TO 200 C 170 DO 180 I = 1, N IF (USEFLO) THEN FRAC = RHOR(FLO1) FLO1 = FLO1 + FLOINC ENDIF CALL L7IVM(PX, Z, L, DR(1,I)) S = D7TPR(PX, Z, Z) T = ONE - FRAC*RD(I) * S IF (T .LE. ZERO) THEN RD(I) = NEGONE IF (XNI .GT. 0) THEN CALL V7CPY(PX, RHOR(XNI), X) XNI = XNI + PX ENDIF ELSE RD(I) = HALF * FRAC * (R(I)/T)**2 * S IF (XNI .GT. 0) THEN CALL L7ITV(PX, Z, L, Z) CALL V2AXY(PX, RHOR(XNI), FRAC*R(I)/T, Z, X) XNI = XNI + PX ENDIF ENDIF 180 CONTINUE GO TO 200 C 190 CALL V7SCP(N1, RD, NEGONE) 200 IV(REGD) = 1 C 999 RETURN C *** LAST LINE OF G2LRD FOLLOWS *** END SUBROUTINE G7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) REAL D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 82. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C G7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND G7LIT BUILDS AN C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD C VECTOR USED IN UPDATING S. G7LIT DECIDES DYNAMICALLY WHETHER OR C NOT TO USE S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR C HC + S (AUGMENTED MODEL). C C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S, G7LIT ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING G7LIT WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY G7LIT OR THE SUBROUTINES IT CALLS. C C WHEN G7LIT IS FIRST CALLED, I.E., WHEN G7LIT IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES, G7LIT RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE G7LIT WILL MAKE A C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL G7LIT AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE G7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME G7LIT RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL G7LIT AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(TOOBIG) TO 1, IN WHICH CASE G7LIT WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1, 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, 2 TEMP1, TEMP2, W1, X01 REAL E, STTSST, T, T1 C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, L7SVX, L7SVN, RLDST, R7MDC, V2NRM EXTERNAL A7SST, D7TPR, F7HES, G7QTS, ITSUM, L7MST, L7SRT, 1 L7SQR, L7SVX, L7SVN, L7TVM, L7VML, PARCK, RLDST, 2 R7MDC, S7LUP, S7LVM, STOPX, V2AXY, V7CPY, V7SCP, 3 V2NRM C C A7SST.... ASSESSES CANDIDATE STEP. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C F7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE). C G7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C L7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C L7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C L7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C L7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX. C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C PARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C S7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F, 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS, 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL, 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV, 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR, 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED, 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE, 8 XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C 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.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, 1 ZERO=0.E+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 PARCK(1, D, IV, LIV, LV, P, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I C C *** STORAGE ALLOCATION *** C 10 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(W) = IV(DIG) + P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IF (IV(1) .NE. 13) GO TO 20 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 20 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(RESTOR) = 0 IV(FDH) = 0 V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(S) .LT. 0) GO TO 999 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL V7SCP(P*(P+1)/2, V(S1), ZERO) IV(1) = 1 J = IV(IPIVOT) IF (J .LE. 0) GO TO 999 DO 30 I = 1, P IV(J) = I J = J + 1 30 CONTINUE GO TO 999 C C *** NEW FUNCTION VALUE *** C 40 IF (IV(MODE) .EQ. 0) GO TO 290 IF (IV(MODE) .GT. 0) GO TO 520 C IV(1) = 2 IF (IV(TOOBIG) .EQ. 0) GO TO 999 IV(1) = 63 GO TO 999 C C *** NEW GRADIENT *** C 50 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 520 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 65 GO TO 999 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610 C C *** COMPUTE D**-1 * GRADIENT *** C DIG1 = IV(DIG) K = DIG1 DO 70 I = 1, P V(K) = G(I) / D(I) K = K + 1 70 CONTINUE V(DGNORM) = V2NRM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 510 IF (IV(MODE) .EQ. 0) GO TO 440 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 100 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 530 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 80 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 90 CALL V2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 100 90 RMAT1 = IV(RMAT) CALL L7SQR(PS, V(S1), V(RMAT1)) CALL V2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1)) 100 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 110 CALL ITSUM(D, G, IV, LIV, LV, P, V, X) 120 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 130 IV(1) = 10 GO TO 999 130 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 150 STEP1 = IV(STEP) DO 140 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 140 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * V2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 150 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL V7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 160 IF (.NOT. STOPX(DUMMY)) GO TO 180 IV(1) = 11 GO TO 190 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 170 IF (V(F) .GE. V(F0)) GO TO 180 V(RADFAC) = ONE K = IV(NITER) GO TO 130 C 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200 IV(1) = 9 190 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 430 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 200 STEP1 = IV(STEP) W1 = IV(W) H1 = IV(H) T1 = ONE IF (IV(MODEL) .EQ. 2) GO TO 210 T1 = ZERO C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 210 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 210 IPIV1 = IV(IPIVOT) CALL L7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1), 1 V(RMAT1), V(STEP1), V, V(W1)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION G7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 260 C 210 IF (H1 .GT. 0) GO TO 250 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C H1 = -H1 IV(H) = H1 IV(FDH) = 0 J = IV(HC) IF (J .GT. 0) GO TO 220 J = H1 RMAT1 = IV(RMAT) CALL L7SQR(P, V(H1), V(RMAT1)) 220 S1 = IV(S) DO 240 I = 1, P T = ONE / D(I) DO 230 K = 1, I V(H1) = T * (V(J) + T1*V(S1)) / D(K) J = J + 1 H1 = H1 + 1 S1 = S1 + 1 230 CONTINUE 240 CONTINUE H1 = IV(H) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 250 DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL G7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), 1 V, V(W1)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 260 IF (IV(IRC) .NE. 6) GO TO 270 IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 2 GO TO 300 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 270 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 290 IF (IV(IRC) .NE. 5) GO TO 280 IF (V(RADFAC) .LE. ONE) GO TO 280 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280 IF (IV(RESTOR) .NE. 2) GO TO 290 RSTRST = 0 GO TO 300 C C *** COMPUTE F(X0 + STEP) *** C 280 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 290 RSTRST = 3 300 X01 = IV(X0) V(RELDX) = RLDST(P, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = IV(STLSTG) I = IV(RESTOR) + 1 GO TO (340, 310, 320, 330), I 310 CALL V7CPY(P, X, V(X01)) GO TO 340 320 CALL V7CPY(P, V(LSTGST), V(STEP1)) GO TO 340 330 CALL V7CPY(P, V(STEP1), V(LSTGST)) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = RLDST(P, D, X, V(X01)) IV(RESTOR) = RSTRST C C *** IF NECESSARY, SWITCH MODELS *** C 340 IF (IV(SWITCH) .EQ. 0) GO TO 350 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V, V(L)) 350 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL S7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * D7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 360 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 400 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V(L), V) GO TO 160 C 360 IF (-3 .LT. L) GO TO 400 C C *** RECOMPUTE STEP WITH NEW RADIUS *** C 370 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 160 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST C 380 V(RADIUS) = V(LMAXS) GO TO 200 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 390 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 510 IF (IV(XIRC) .EQ. 14) GO TO 510 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 400 IV(COVMAT) = 0 IV(REGD) = 0 C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C IF (IV(IRC) .NE. 3) GO TO 430 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(W) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 410 CALL S7LVM(P, V(TEMP1), V(HC1), V(STEP1)) GO TO 420 410 RMAT1 = IV(RMAT) CALL L7TVM(P, V(TEMP1), V(RMAT1), V(STEP1)) CALL L7VML(P, V(TEMP1), V(RMAT1), V(TEMP1)) C 420 IF (STPMOD .EQ. 1) GO TO 430 S1 = IV(S) CALL S7LVM(PS, V(TEMP2), V(S1), V(STEP1)) CALL V2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1)) C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 430 IV(NGCALL) = IV(NGCALL) + 1 G01 = IV(W) CALL V7CPY(P, V(G01), G) IV(1) = 2 IV(TOOBIG) = 0 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 440 G01 = IV(W) CALL V2AXY(P, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(W) IF (IV(IRC) .NE. 3) GO TO 470 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 450 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 450 CONTINUE C C *** DO GRADIENT TESTS *** C IF ( V2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 460 IF ( D7TPR(P, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 470 460 V(RADFAC) = V(INCFAC) C C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S *** C 470 CALL V2AXY(PS, Y, NEGONE, Y, G) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL S7LVM(PS, V(TEMP1), V(S1), V(STEP1)) C T1 = ABS( D7TPR(PS, V(STEP1), V(TEMP1))) T = ABS( D7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL S7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 490 C 480 RMAT1 = IV(RMAT) CALL L7TVM(PS, V(G01), V(RMAT1), V(STEP1)) CALL L7VML(PS, V(G01), V(RMAT1), V(G01)) C 490 CALL V2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL S7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 110 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 500 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 510 IF (IV(RDREQ) .EQ. 0) GO TO 600 IF (IV(FDH) .NE. 0) GO TO 600 IF (IV(CNVCOD) .GE. 7) GO TO 600 IF (IV(REGD) .GT. 0) GO TO 600 IF (IV(COVMAT) .GT. 0) GO TO 600 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 530 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 520 IV(RESTOR) = 0 530 CALL F7HES(D, G, I, IV, LIV, LV, P, V, X) GO TO (540, 550, 580), I 540 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 999 C 550 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) IV(1) = 2 GO TO 999 C 560 H1 = IABS(IV(H)) IV(H) = -H1 PP1O2 = P * (P + 1) / 2 RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 570 LMAT1 = IV(LMAT) CALL V7CPY(PP1O2, V(LMAT1), V(RMAT1)) V(RCOND) = ZERO GO TO 590 570 HC1 = IV(HC) IV(FDH) = H1 CALL V7CPY(P*(P+1)/2, V(H1), V(HC1)) C C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN C *** FOR USE IN CALLER*S COVARIANCE CALCULATION... C 580 LMAT1 = IV(LMAT) H1 = IV(FDH) IF (H1 .LE. 0) GO TO 600 IF (IV(CNVCOD) .EQ. 70) GO TO 80 CALL L7SRT(1, P, V(LMAT1), V(H1), I) IV(FDH) = -1 V(RCOND) = ZERO IF (I .NE. 0) GO TO 600 C 590 IV(FDH) = -1 STEP1 = IV(STEP) T = L7SVN(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .LE. ZERO) GO TO 600 T = T / L7SVX(P, V(LMAT1), V(STEP1), V(STEP1)) IF (T .GT. R7MDC(4)) IV(FDH) = H1 V(RCOND) = T C 600 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 610 IV(1) = 1400 C 999 RETURN C C *** LAST LINE OF G7LIT FOLLOWS *** END SUBROUTINE L7NVR(N, LIN, L) C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C *** PARAMETERS *** C INTEGER N REAL L(1), LIN(1) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 REAL ONE, T, ZERO PARAMETER (ONE=1.E+0, ZERO=0.E+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 LINE OF L7NVR FOLLOWS *** END SUBROUTINE L7TSQ(N, A, L) C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C INTEGER N REAL A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C INTEGER I, II, IIM1, I1, J, K, M REAL LII, LJ C II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C 999 RETURN C *** LAST LINE OF L7TSQ FOLLOWS *** END SUBROUTINE N3RDP(IV, LIV, LV, N, P, RD, RHOI, RHOR, V) C C *** PRINT REGRESSION DIAGNOSTICS FOR MLPSL AND NL2S1 *** C INTEGER LIV, LV, N, P INTEGER IV(LIV), RHOI(*) REAL RD(N), RHOR(*), V(LV) C C *** NOTE -- V IS PASSED FOR POSSIBLE USE BY REVISED VERSIONS OF C *** THIS ROUTINE. C INTEGER COV1, I, I1, I2, IEND, II, J, K, K1, NI, PU, PX, PX1, XNI C C *** IV AND V SUBSCRIPTS *** C INTEGER BS, BSSTR, COVMAT, COVPRT, COVREQ, LOO, NB, NEEDHD, NFCOV, 1 NFIX, NGCOV, PRUNIT, RDREQ, REGD, RCOND, STATPR, XNOTI C PARAMETER (BS=85, BSSTR=86, COVMAT=26, COVPRT=14, COVREQ=15, 1 LOO=84, NB=87, NEEDHD=36, NFCOV=52, NFIX=83, NGCOV=53, 2 PRUNIT=21, RDREQ=57, REGD=67, RCOND=53, STATPR=23, 3 XNOTI=90) C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IF (IV(STATPR) .EQ. 0) GO TO 30 IF (IV(NFCOV) .GT. 0) WRITE(PU,10) IV(NFCOV) 10 FORMAT(/1X,I4,50H EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOST 1ICS.) IF (IV(NGCOV) .GT. 0) WRITE(PU,20) IV(NGCOV) 20 FORMAT(1X,I4,50H EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTI 1CS.) IF (IV(NFCOV) .GT. 0 .OR. IV(NGCOV) .GT. 0) IV(NEEDHD) = 1 C 30 IF (IV(COVPRT) .LE. 0) GO TO 999 COV1 = IV(COVMAT) IF (IV(REGD) .LE. 0 .AND. COV1 .LE. 0) GO TO 70 IV(NEEDHD) = 1 IF (IABS(IV(COVREQ)) .GT. 2) GO TO 50 C WRITE(PU,40) V(RCOND) 40 FORMAT(/53H SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST, 1 G10.2) GO TO 70 C 50 WRITE(PU,60) V(RCOND) 60 FORMAT(/54H SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST, 1 G10.2) C 70 IF (MOD(IV(COVPRT),2) .EQ. 0) GO TO 210 IV(NEEDHD) = 1 IF (COV1) 80,110,130 80 IF (-1 .EQ. COV1) WRITE(PU,90) 90 FORMAT(/43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,100) 100 FORMAT(/52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 110 WRITE(PU,120 ) 120 FORMAT(/45H ++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 210 C 130 IF (IABS(IV(COVREQ)) .LT. 3) GO TO 150 WRITE(PU,140) 140 FORMAT(/35H COVARIANCE = (J**T * RHO" * J)**-1/) GO TO 170 150 WRITE(PU,160) 160 FORMAT(/56H COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIA 1N/) 170 II = COV1 - 1 DO 180 I = 1, P I1 = II + 1 I2 = II + MIN(I, 5) II = II + I WRITE(PU,190) I, (V(J), J = I1, I2) IF (I .LE. 5) GO TO 180 I2 = I2 + 1 WRITE(PU,200) (V(J), J = I2, II) 180 CONTINUE 190 FORMAT(4H ROW,I3,2X,5G12.3) 200 FORMAT(9X,5G12.3) 210 IF (IV(COVPRT) .LT. 2) GO TO 999 I = IV(REGD) + 4 GO TO (230, 250, 270, 290, 310), I WRITE(PU,220) IV(REGD) 220 FORMAT(/18H BUG... IV(REGD) =,I10) GO TO 999 230 WRITE(PU,240) NB, IV(NB) 240 FORMAT(/17H BAD IV(NB) = IV(,I2,3H) =,I10) GO TO 999 250 WRITE(PU,260) NFIX, IV(NFIX) 260 FORMAT(/19H BAD IV(NFIX) = IV(,I2,3H) =,I10) GO TO 999 270 WRITE(PU,280) LOO, IV(LOO) 280 FORMAT(/18H BAD IV(LOO) = IV(,I2,3H) =,I10) GO TO 999 290 WRITE(PU,300) 300 FORMAT(/42H REGRESSION DIAGNOSTIC VECTOR NOT COMPUTED) GO TO 999 310 IV(NEEDHD) = 1 XNI = 0 I = MOD(IV(RDREQ)/2, 3) + 1 GO TO (999, 330, 320), I 320 XNI = IV(XNOTI) PX = P - IV(NFIX) PX1 = PX - 1 IF (IV(LOO) .GT. 1) GO TO 400 330 WRITE(PU,340) 340 FORMAT (74H REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * 1 H(I)**-1 * G(I)...) IF (XNI .LE. 0) GO TO 380 WRITE(PU, 350) 350 FORMAT(29H I RD(I) X(I)) DO 360 I = 1, N WRITE(PU, 370) I, RD(I), (RHOR(J), J = XNI, XNI+PX1) XNI = XNI + PX 360 CONTINUE 370 FORMAT(1X,I5,G13.3,4G15.6/(19X,4G15.6)) GO TO 999 C 380 WRITE(PU,390) RD 390 FORMAT(6G12.3) GO TO 999 C 400 WRITE(PU,410) 410 FORMAT(/77H BLOCK REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 1 * H * H(I)**-1 * G(I)) NI = IV(NB) K = IV(BS) K1 = IV(BSSTR) IEND = 0 IF (XNI .GT. 0) GO TO 450 WRITE(PU,420) 420 FORMAT(28H BLOCK FIRST LAST RD(I)) DO 440 I = 1, NI I1 = IEND + 1 IF (I1 .GT. N) GO TO 999 IEND = IEND + RHOI(K) K = K + K1 IF (IEND .GT. N) IEND = N WRITE(PU,430) I, I1, IEND, RD(I) 430 FORMAT(I6,I7,I6,G12.3) 440 CONTINUE GO TO 999 C 450 WRITE(PU, 460) 460 FORMAT(41H BLOCK FIRST LAST RD(I) X(I)) DO 480 I = 1, NI I1 = IEND + 1 IF (I1 .GT. N) GO TO 999 IEND = IEND + RHOI(K) K = K + K1 IF (IEND .GT. N) IEND = N WRITE(PU,470) I, I1, IEND, RD(I), (RHOR(J), J = XNI, XNI+PX1) 470 FORMAT(I6,I7,I6,G12.3,3G15.6/(31X,3G15.6)) XNI = XNI + PX 480 CONTINUE C 999 RETURN C *** LAST LINE OF N3RDP FOLLOWS *** END //GO.SYSIN DD sglfg.f cat >sglfgb.f <<'//GO.SYSIN DD sglfgb.f' SUBROUTINE GLGB(N, P, PS, X, B, RHO, RHOI, RHOR, IV, LIV, LV, 1 V, CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION A LA NL2SOL, PLUS SIMPLE BOUNDS *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) REAL B(2,P), X(P), RHOR(*), V(LV), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C B....... BOUNDS TO ENFORCE... B(1,I) .LE. X(I) .LE. B(2,I). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE RGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR AND JACOBIAN MATRIX. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED IS AN INTEGER ARRAY OF LENGTH 2... C NEED(1) = 1 MEANS CALCRJ SHOULD COMPUTE THE RESIDUAL VECTOR R, C AND NEED(2) IS THE VALUE NF HAD AT THE LAST X WHERE C CALCRJ MIGHT BE CALLED WITH NEED(1) = 2. C NEED(1) = 2 MEANS CALCRJ SHOULD COMPUTE THE JACOBIAN MATRIX RP, C WHERE RP(J,I) = DERIVATIVE OF R(I) WITH RESPECT TO X(J). C (CALCRJ SHOULD NOT CHANGE NEED AND SHOULD CHANGE AT MOST ONE OF R C AND RP. IF R OR RP, AS APPROPRIATE, CANNOT BE COMPUTED, THEN CALCRJ C SHOULD SET NF TO 0. OTHERWISE IT SHOULD NOT CHANGE NF.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RGLGB C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RGLGB... CARRIES OUT OPTIMIZATION ITERATIONS. C C C *** LOCAL VARIABLES *** C INTEGER D1, DR1, I, IV1, NEED1(2), NEED2(2), NF, R1, RD1 C C *** IV COMPONENTS *** C INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61, 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+1+I) CALL RGLGB(B, X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, 1 RHO, RHOI,RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 1)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) C 20 CALL RGLGB(B, V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, 1 V(R1), V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 60 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL CALCRJ(N, PS, X, NF, NEED1, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE DR = GRADIENT OF R COMPONENTS *** C 50 CALL CALCRJ(N, PS, X, IV(NFGCAL), NEED2, V(R1), V(DR1), UI, UR,UF) IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1 GO TO 20 C C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED C *** AND PRINT IT IF SO REQUESTED... C 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1 C 999 RETURN C C *** LAST LINE OF GLGB FOLLOWS *** END SUBROUTINE GLFB(N, P, PS, X, B, RHO, RHOI, RHOR, IV, LIV, LV, V, 1 CALCRJ, UI, UR, UF) C C *** GENERALIZED LINEAR REGRESSION, FINITE-DIFFERENCE JACOBIAN *** C *** WITH SIMPLE BOUNDS ON X *** C C *** PARAMETERS *** C INTEGER N, P, PS, LIV, LV INTEGER IV(LIV), RHOI(*), UI(*) REAL B(2,P), X(P), V(LV), RHOR(*), UR(*) EXTERNAL CALCRJ, RHO, UF C C *** PARAMETER USAGE *** C C N....... TOTAL NUMBER OF RESIDUALS. C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS...... NUMBER OF NON-NUISANCE PARAMETERS (THOSE INVOLVED IN S). C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C B....... BOUNDS TO ENFORCE... B(1,I) .LE. X(I) .LE. B(2,I). C RHO..... SUBROUTINE FOR COMPUTING LOSS FUNCTIONS AND THEIR DERIVS. C SEE RGLG FOR DETAILS ABOUT RHO. C RHOI.... PASSED WITHOUT CHANGE TO RHO. C RHOR.... PASSED WITHOUT CHANGE TO RHO. C IV...... INTEGER VALUES ARRAY. C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW). C LV...... LENGTH OF V (SEE DISCUSSION BELOW). C V....... FLOATING-POINT VALUES ARRAY. C CALCRJ.. SUBROUTINE FOR COMPUTING RESIDUAL VECTOR. C UI...... PASSED UNCHANGED TO CALCRJ. C UR...... PASSED UNCHANGED TO CALCRJ. C UF...... PASSED UNCHANGED TO CALCRJ. C C *** CALCRJ CALLING SEQUENCE... C C CALL CALCRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) C C PARAMETERS N, P, X, UI, UR, AND UF ARE AS ABOVE. C R AND RP ARE FLOATING-POINT ARRAYS DIMENSIONED R(N) AND RP(P,N). C NEED MAY BE REGARDED AS AN INTEGER THAT ALWAYS HAS THE VALUE 1 C WHEN GLFB CALLS CALCRJ. THIS MEANS CALCRJ SHOULD COMPUTE THE C RESIDUAL VECTOR R. (CALCRJ SHOULD NOT CHANGE NEED OR RP. IF R C CANNOT BE COMPUTED, THEN CALCRJ SHOULD SET NF TO 0. OTHERWISE IT C SHOULD NOT CHANGE NF. FOR COMPATIBILITY WITH GLG, NEED IS A C VECTOR OF LENGTH 2.) C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C *** EXTERNAL SUBROUTINES *** C EXTERNAL IVSET, RGLGB, V7CPY C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C RGLGB... CARRIES OUT OPTIMIZATION ITERATIONS. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER D1, DK, DR1, I, I1, IV1, J1K, J1K0, K, NEED(2), NF, 1 NG, RD1, R1, R21, RS1, RSN REAL H, H0, HLIM, NEGPT5, T, ONE, XK, XK1, ZERO C C *** IV AND V COMPONENTS *** C INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL, 1 NGCALL, NGCOV, R, REGD0, TOOBIG, VNEED PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35, 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53, 2 R=61, REGD0=82, TOOBIG=2, VNEED=4) SAVE NEED DATA HLIM/0.1E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ DATA NEED(1)/1/, NEED(2)/0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IV1 = IV(1) IF (IV1 .EQ. 14) GO TO 10 IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10 IF (IV1 .EQ. 12) IV(1) = 13 I = (P-PS+2)*(P-PS+1)/2 IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+3+I) CALL RGLGB(B, X, V, IV, LIV, LV, N, PS, N, P, PS, V, V, RHO, 1 RHOI, RHOR, V, X) IF (IV(1) .NE. 14) GO TO 999 C C *** STORAGE ALLOCATION *** C IV(D) = IV(NEXTV) IV(R) = IV(D) + P IV(REGD0) = IV(R) + (P - PS + 3)*N IV(J) = IV(REGD0) + ((P-PS+2)*(P-PS+1)/2)*N IV(NEXTV) = IV(J) + N*PS IF (IV1 .EQ. 13) GO TO 999 C 10 D1 = IV(D) DR1 = IV(J) R1 = IV(R) RD1 = IV(REGD0) R21 = RD1 - N RS1 = R21 - N RSN = RS1 + N - 1 C 20 CALL RGLGB(B, V(D1), V(DR1), IV, LIV, LV, N, PS, N, P, PS, 1 V(R1), V(RD1), RHO, RHOI, RHOR, V, X) IF (IV(1)-2) 30, 50, 999 C C *** NEW FUNCTION VALUE (R VALUE) NEEDED *** C 30 NF = IV(NFCALL) CALL CALCRJ(N, PS, X, NF, NEED, V(R1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 40 IV(TOOBIG) = 1 GO TO 20 40 CALL V7CPY(N, V(RS1), V(R1)) IF (IV(1) .GT. 0) GO TO 20 C C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R *** C C *** INITIALIZE D IF NECESSARY *** C 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO) 1 CALL V7SCP(P, V(D1), ONE) C DK = D1 NG = IV(NGCALL) - 1 IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1 J1K0 = DR1 NF = IV(NFCALL) IF (NF .EQ. IV(NFGCAL)) GO TO 70 NG = NG + 1 CALL CALCRJ(N, PS, X, NF, NEED, V(RS1), V(DR1), UI, UR, UF) IF (NF .GT. 0) GO TO 70 60 IV(TOOBIG) = 1 IV(NGCALL) = NG GO TO 20 70 DO 130 K = 1, PS J1K = J1K0 J1K0 = J1K0 + 1 IF (B(1,K) .GE. B(2,K)) GO TO 120 XK = X(K) H = V(DLTFDJ) * MAX( ABS(XK), ONE/V(DK)) H0 = H DK = DK + 1 T = NEGPT5 XK1 = XK + H IF (XK - H .GE. B(1,K)) GO TO 80 T = -T IF (XK1 .GT. B(2,K)) GO TO 60 80 IF (XK1 .LE. B(2,K)) GO TO 90 T = -T H = -H XK1 = XK + H IF (XK1 .LT. B(1,K)) GO TO 60 90 X(K) = XK1 NF = IV(NFGCAL) CALL CALCRJ(N, PS, X, NF, NEED, V(R21), V(DR1), UI, UR, UF) NG = NG + 1 IF (NF .GT. 0) GO TO 100 H = T * H XK1 = XK + H IF ( ABS(H/H0) .GE. HLIM) GO TO 90 GO TO 60 100 X(K) = XK IV(NGCALL) = NG I1 = R21 DO 110 I = RS1, RSN V(J1K) = (V(I1) - V(I)) / H I1 = I1 + 1 J1K = J1K + PS 110 CONTINUE GO TO 130 C *** SUPPLY A ZERO DERIVATIVE FOR CONSTANT COMPONENTS... 120 DO 125 I = 1, N V(J1K) = ZERO J1K = J1K + PS 125 CONTINUE 130 CONTINUE GO TO 20 C 999 RETURN C C *** LAST LINE OF GLFB FOLLOWS *** END SUBROUTINE RGLGB(B, D, DR, IV, LIV, LV, N, ND, NN, P, PS, R, 1 RD, RHO, RHOI, RHOR, V, X) C C *** ITERATION DRIVER FOR GENERALIZED (NON)LINEAR MODELS (ETC.) C INTEGER LIV, LV, N, ND, NN, P, PS INTEGER IV(LIV), RHOI(*) REAL B(2,P), D(P), DR(ND,N), R(*), RD(*), RHOR(*), 1 V(LV), X(*) C DIMENSION RD(N, (P-PS)*(P-PS+1)/2 + 1) EXTERNAL RHO 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 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....... LEADING DIMENSION OF DR -- MUST BE AT LEAST PS. C NN....... LEAD DIMENSION OF R, RD. C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED. C PS....... NUMBER OF NON-NUISANCE PARAMETERS. C R........ RESIDUALS (OR MEANS -- FUNCTIONS OF X) WHEN RGLGB IS CALLED C WITH IV(1) = 1. C RD....... TEMPORARY STORAGE. C RHO...... COMPUTES INFO ABOUT OBJECTIVE FUNCTION. C RHOI..... PASSED WITHOUT CHANGE TO RHO. C RHOR..... PASSED WITHOUT CHANGE TO RHO. C V........ FLOATING-POINT VALUES ARRAY. C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS, C OUTPUT = BEST VALUE FOUND). C C *** CALLING SEQUENCE FOR RHO... C C CALL RHO(NEED, F, N, NF, XN, R, RD, RHOI, RHOR, W) C C PARAMETER DECLARATIONS FOR RHO... C C INTEGER NEED(2), N, NF, RHOI(*) C FLOATING-POINT F, XN(*), R(*), RD(N,*), RHOR(*), W(N) C C RHOI AND RHOR ARE FOR RHO TO USE AS IT SEES FIT. THEY ARE PASSED C TO RHO WITHOUT CHANGE. C F, R, RD, AND W ARE EXPLAINED BELOW WITH NEED. C XN IS THE VECTOR OF NUISANCE PARAMETERS (OF LENGTH P - PS). IF C RHO NEEDS TO KNOW THE LENGTH OF XN, THEN THIS LENGTH SHOULD BE C COMMUNICATED THROUGH RHOI (OR THROUGH COMMON). RHO SHOULD NOT CHANGE C XN. C NEED(1) = 1 MEANS RHO SHOULD SET F TO THE SUM OF THE LOSS FUNCTION C VALUES AT THE RESIDUALS R(I). NF IS THE CURRENT FUNCTION INVOCATION C COUNT (A VALUE THAT IS INCREMENTED EACH TIME A NEW PARAMETER EXTIMATE C X IS CONSIDERED). NEED(2) IS THE VALUE NF HAD AT THE LAST R WHERE C RHO MIGHT BE CALLED WITH NEED(1) = 2. IF RHO SAVES INTERMEDIATE C RESULTS FOR USE IN CALLS WITH NEED(1) = 2, THEN IT CAN USE NF TO TELL C WHICH INTERMEDIATE RESULTS ARE APPROPRIATE, AND IT CAN SAVE SOME OF C THESE RESULTS IN R. C NEED(1) = 2 MEANS RHO SHOULD SET R(I) TO THE LOSS FUNCTION C DERIVATIVE WITH RESPECT TO THE RESIDUALS THAT WERE PASSED TO RHO WHEN C NF HAD THE SAME VALUE IT DOES NOW (AND NEED(1) WAS 1). RHO SHOULD C ALSO SET W(I) TO THE APPROXIMATION OF THE SECOND DERIVATIVE OF THE C LOSS FUNCTION (WITH RESPECT TO THE I-TH RESIDUAL) THAT SHOULD BE USED C IN THE GAUSS-NEWTON MODEL. WHEN THERE ARE NUISANCE PARAMETERS (I.E., C WHEN PS .LT. P) RHO SHOULD ALSO SET R(I+K*N) TO THE DERIVATIVE OF THE C LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL AND XN(K), AND IT C SHOULD SET RD(I,J + K*(K+1)/2 + 1) TO THE SECOND PARTIAL DERIVATIVE C OF THE I-TH RESIDUAL WITH RESPECT TO XN(J) AND XN(K), 0 .LE. J .LE. K C AND 1 .LE. K .LE. P - PS, WHERE XN(0) MEANS THE I-TH RESIDUAL ITSELF. C IN ANY EVENT, RHO SHOULD ALSO SET RD(I,1) TO THE (TRUE) SECOND C DERIVATIVE OF THE LOSS FUNCTION WITH RESPECT TO THE I-TH RESIDUAL. C NF (THE FUNCTION INVOCATION COUNT WHOSE NORMAL USE IS EXPLAINED C ABOVE) SHOULD NOT BE CHANGED UNLESS RHO CANNOT CARRY OUT THE REQUESTED C TASK, IN WHICH CASE RHO SHOULD SET NF TO 0. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL IVSET, D7TPR, D7UP5, G7ITB, ITSUM, L7ITV, L7IVM, 1 L7SRT, L7SQR, L7SVX, L7SVN, L7VML, O7PRD, 2 Q7ADR, V2AXY, V7CPY, V7SCL, V7SCP, VSUM REAL D7TPR, L7SVX, L7SVN, VSUM C C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS. C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS. C D7UP5... UPDATES SCALE VECTOR D. C G7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM. C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X. C L7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR. C L7IVM... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C L7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX. C L7SQR... COMPUTES L*(L**T) FOR LOWER TRIANG. MATRIX L. C L7SVX... UNDERESTIMATES LARGEST SINGULAR VALUE OF TRIANG. MATRIX. C L7SVN... OVERESTIMATES SMALLEST SINGULAR VALUE OF TRIANG. MATRIX. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C O7PRD.... ADDS OUTER PRODUCT OF VECTORS TO A MATRIX. C Q7ADR... ADDS ROWS TO QR FACTORIZATION. C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V7SCL... MULTIPLIES A VECTOR BY A SCALAR. C VSUM.... RETURNS SUM OF ELEMENTS OF A VECTOR. C C *** LOCAL VARIABLES *** C LOGICAL UPDATD, ZEROG INTEGER G1, HN1, I, II, IV1, J, J1, JTOL1, K, LH, 1 NEED1(2), NEED2(2), PMPS, PS1, PSLEN, QTR1, 2 RMAT1, STEP1, TEMP1, TEMP2, TEMP3, TEMP4, W, WI, Y1 REAL RHMAX, RHTOL, RHO1, RHO2, T C REAL ONE, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, 1 F0, G, HC, IPIVOT, IVNEED, JCN, JTOL, LMAT, 2 MODE, NEXTIV, NEXTV, NF0, NF1, NFCALL, NFGCAL, 3 QTR, RDREQ, REGD, RESTOR, RMAT, 4 RSPTOL, STEP, TOOBIG, VNEED C C *** IV SUBSCRIPT VALUES *** C PARAMETER (DTYPE=16, F0=13, G=28, HC=71, IPIVOT=76, IVNEED=3, 1 JCN=66, JTOL=59, LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, 2 NFCALL=6, NF0=68, NF1=69, NFGCAL=7, QTR=77, RESTOR=9, 3 RMAT=78, RDREQ=57, REGD=67, STEP=40, TOOBIG=2, VNEED=4) C C *** V SUBSCRIPT VALUES *** C PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RSPTOL=49) PARAMETER (ONE=1.E+0, ZERO=0.E+0) SAVE NEED1, NEED2 DATA NEED1(1)/1/, NEED1(2)/0/, NEED2(1)/2/, NEED2(2)/0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C LH = P * (P+1) / 2 IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) PS1 = PS + 1 IV1 = IV(1) IF (IV1 .GT. 2) GO TO 10 W = IV(G) - N IV(RESTOR) = 0 IF (IV(TOOBIG) .EQ. 0) GO TO (110, 120), IV1 V(F) = V(F0) IF (IV1 .NE. 1) IV(1) = 2 GO TO 40 C C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS *** C 10 IF (ND .LT. PS) GO TO 340 IF (PS .GT. P) GO TO 340 IF (PS .LE. 0) GO TO 340 IF (N .LE. 0) GO TO 340 IF (IV1 .EQ. 14) GO TO 30 IF (IV1 .GT. 16) GO TO 360 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 + 2*N + 4*PS 20 CALL G7ITB(B, D, X, IV, LIV, LV, P, PS, 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(G) = IV(NEXTV) + P + N IV(RMAT) = IV(G) + P + 4*PS IV(QTR) = IV(RMAT) + LH IV(JTOL) = IV(QTR) + P + N IV(JCN) = IV(JTOL) + 2*P IV(NEXTV) = IV(JCN) + 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 C 40 G1 = IV(G) Y1 = G1 - (P + N) CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, PS, V, X, V(Y1)) IF (IV(1) - 2) 50, 60, 350 C 50 V(F) = ZERO IF (IV(NF1) .EQ. 0) GO TO 999 IF (IV(RESTOR) .NE. 2) GO TO 999 IV(NF0) = IV(NF1) CALL V7CPY(N, RD, R) IV(REGD) = 0 GO TO 999 C 60 CALL V7SCP(P, V(G1), ZERO) RMAT1 = IABS(IV(RMAT)) QTR1 = IABS(IV(QTR)) CALL V7SCP(PS, V(QTR1), ZERO) IV(REGD) = 0 CALL V7SCP(PS, V(Y1), ZERO) CALL V7SCP(LH, V(RMAT1), ZERO) IF (IV(RESTOR) .NE. 3) GO TO 70 CALL V7CPY(N, R, RD) IV(NF1) = IV(NF0) 70 CALL RHO(NEED2, T, N, IV(NFGCAL), X(PS1), R, RD, RHOI, RHOR, V(W)) IF (IV(NFGCAL) .GT. 0) GO TO 90 80 IV(TOOBIG) = 1 GO TO 40 90 IF (IV(MODE) .LT. 0) GO TO 999 DO 100 I = 1, N 100 CALL V2AXY(PS, V(Y1), R(I), DR(1,I), V(Y1)) GO TO 999 C C *** COMPUTE F(X) *** C 110 I = IV(NFCALL) NEED1(2) = IV(NFGCAL) CALL RHO(NEED1, V(F), N, I, X(PS1), R, RD, RHOI, RHOR, V(W)) IV(NF1) = I IF (I .LE. 0) GO TO 80 GO TO 40 C 120 G1 = IV(G) C C *** DECIDE WHETHER TO UPDATE D BELOW *** C I = IV(DTYPE) UPDATD = .FALSE. IF (I .LE. 0) GO TO 130 IF (I .EQ. 1 .OR. IV(MODE) .LT. 0) UPDATD = .TRUE. C C *** COMPUTE RMAT AND QTR *** C 130 QTR1 = IABS(IV(QTR)) RMAT1 = IABS(IV(RMAT)) IV(RMAT) = RMAT1 IV(HC) = 0 IV(NF0) = 0 IV(NF1) = 0 IF (IV(MODE) .LT. 0) GO TO 150 C C *** ADJUST Y *** C Y1 = IV(G) - (P + N) WI = W STEP1 = IV(STEP) DO 140 I = 1, N T = V(WI) - RD(I) WI = WI + 1 IF (T .NE. ZERO) CALL V2AXY(PS, V(Y1), 1 T* D7TPR(PS,V(STEP1),DR(1,I)), DR(1,I), V(Y1)) 140 CONTINUE C C *** CHECK FOR NEGATIVE W COMPONENTS *** C 150 J1 = W + N - 1 DO 160 WI = W, J1 IF (V(WI) .LT. ZERO) GO TO 230 160 CONTINUE C C *** W IS NONNEGATIVE. COMPUTE QR FACTORIZATION *** C *** AND, IF NECESSARY, USE SEMINORMAL EQUATIONS *** C RHMAX = ZERO RHTOL = V(RSPTOL) TEMP1 = G1 + P ZEROG = .TRUE. WI = W DO 190 I = 1, N RHO1 = R(I) RHO2 = V(WI) WI = WI + 1 T = SQRT(RHO2) IF (RHMAX .LT. RHO2) RHMAX = RHO2 IF (RHO2 .GT. RHTOL*RHMAX) GO TO 170 C *** SEMINORMAL EQUATIONS *** CALL V2AXY(PS, V(G1), RHO1, DR(1,I), V(G1)) RHO1 = ZERO ZEROG = .FALSE. GO TO 180 170 RHO1 = RHO1 / T C *** QR ACCUMULATION *** 180 CALL V7SCL(PS, V(TEMP1), T, DR(1,I)) CALL Q7ADR(PS, V(QTR1), V(RMAT1), V(TEMP1), RHO1) 190 CONTINUE C C *** COMPUTE G FROM RMAT AND QTR *** C TEMP2 = TEMP1 + P CALL L7VML(PS, V(TEMP1), V(RMAT1), V(QTR1)) IF (ZEROG) GO TO 210 IV(QTR) = -QTR1 IF ( L7SVX(PS, V(RMAT1), V(TEMP2), V(TEMP2)) * RHTOL .GE. 1 L7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2))) GO TO 220 CALL L7IVM(PS, V(TEMP2), V(RMAT1), V(G1)) C C *** SEMINORMAL EQUATIONS CORRECTION OF BJOERCK -- C *** ONE CYCLE OF ITERATIVE REFINEMENT... C TEMP3 = TEMP2 + PS TEMP4 = TEMP3 + PS CALL L7ITV(PS, V(TEMP3), V(RMAT1), V(TEMP2)) CALL V7SCP(PS, V(TEMP4), ZERO) RHMAX = ZERO WI = W DO 200 I = 1, N RHO2 = V(WI) WI = WI + 1 IF (RHMAX .LT. RHO2) RHMAX = RHO2 RHO1 = ZERO IF (RHO2 .LE. RHTOL*RHMAX) RHO1 = R(I) T = RHO1 - RHO2* D7TPR(PS, V(TEMP3), DR(1,I)) CALL V2AXY(PS, V(TEMP4), T, DR(1,I), V(TEMP4)) 200 CONTINUE CALL L7IVM(PS, V(TEMP3), V(RMAT1), V(TEMP4)) CALL V2AXY(PS, V(TEMP2), ONE, V(TEMP3), V(TEMP2)) CALL V2AXY(PS, V(QTR1), ONE, V(TEMP2), V(QTR1)) 210 IV(QTR) = QTR1 220 CALL V2AXY(PS, V(G1), ONE, V(TEMP1), V(G1)) IF (PS .GE. P) GO TO 330 GO TO 250 C C *** INDEFINITE GN HESSIAN... *** C 230 IV(RMAT) = -RMAT1 IV(HC) = RMAT1 CALL O7PRD(N, LH, PS, V(RMAT1), V(W), DR, DR) C C *** COMPUTE GRADIENT *** C G1 = IV(G) DO 240 I = 1, N 240 CALL V2AXY(PS, V(G1), R(I), DR(1,I), V(G1)) IF (PS .GE. P) GO TO 330 C C *** COMPUTE GRADIENT COMPONENTS OF NUISANCE PARAMETERS *** C 250 K = P - PS J1 = 1 G1 = G1 + PS DO 260 J = 1, K J1 = J1 + NN V(G1) = VSUM(N, R(J1)) G1 = G1 + 1 260 CONTINUE C C *** COMPUTE HESSIAN COMPONENTS OF NUISANCE PARAMETERS *** C I = PS*PS1/2 PSLEN = P*(P+1)/2 - I HN1 = RMAT1 + I CALL V7SCP(PSLEN, V(HN1), ZERO) PMPS = P - PS K = HN1 J1 = 1 DO 290 II = 1, PMPS J1 = J1 + NN J = J1 DO 270 I = 1, N CALL V2AXY(PS, V(K), RD(J), DR(1,I), V(K)) J = J + 1 270 CONTINUE K = K + PS DO 280 I = 1, II J1 = J1 + NN V(K) = VSUM(N, RD(J1)) K = K + 1 280 CONTINUE 290 CONTINUE IF (IV(RMAT) .LE. 0) GO TO 330 J = IV(LMAT) CALL V7CPY(PSLEN, V(J), V(HN1)) IF ( L7SVN(PS, V(RMAT1), V(TEMP2), V(TEMP2)) .LE. ZERO) GO TO 300 CALL L7SRT(PS1, P, V(RMAT1), V(RMAT1), I) IF (I .LE. 0) GO TO 310 C C *** HESSIAN IS NOT POSITIVE DEFINITE *** C 300 CALL L7SQR(PS, V(RMAT1), V(RMAT1)) CALL V7CPY(PSLEN, V(HN1), V(J)) IV(HC) = RMAT1 IV(RMAT) = -RMAT1 GO TO 330 C C *** NUISANCE PARS LEAVE HESSIAN POS. DEF. GET REST OF QTR *** C 310 J = QTR1 + PS G1 = IV(G) + PS DO 320 I = PS1, P T = D7TPR(I-1, V(HN1), V(QTR1)) HN1 = HN1 + I V(J) = (V(G1) - T) / V(HN1-1) J = J + 1 G1 = G1 + 1 320 CONTINUE 330 IF (UPDATD) CALL D7UP5(D, IV, LIV, LV, P, PS, V) GO TO 40 C C *** MISC. DETAILS *** C C *** BAD N, ND, OR P *** C 340 IV(1) = 66 GO TO 360 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 350 G1 = IV(G) 360 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X) C 999 RETURN C *** LAST LINE OF RGLGB FOLLOWS *** END SUBROUTINE D7MLP(N, X, Y, Z, K) C C *** SET X = DIAG(Y)**K * Z C *** FOR X, Z = LOWER TRIANG. MATRICES STORED COMPACTLY BY ROW C *** K = 1 OR -1. C INTEGER N, K REAL X(*), Y(N), Z(*) INTEGER I, J, L REAL ONE, T DATA ONE/1.E+0/ C L = 1 IF (K .GE. 0) GO TO 30 DO 20 I = 1, N T = ONE / Y(I) DO 10 J = 1, I X(L) = T * Z(L) L = L + 1 10 CONTINUE 20 CONTINUE GO TO 999 C 30 DO 50 I = 1, N T = Y(I) DO 40 J = 1, I X(L) = T * Z(L) L = L + 1 40 CONTINUE 50 CONTINUE 999 RETURN C *** LAST LINE OF D7MLP FOLLOWS *** END SUBROUTINE F7DHB(B, D, G, IRT, IV, LIV, LV, P, V, X) C C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING C *** AT V(IV(FDH)) = V(-IV(H)). HONOR SIMPLE BOUNDS IN B. C C *** IF IV(COVREQ) .GE. 0 THEN F7DHB USES GRADIENT DIFFERENCES, C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN G7LIT. C C IRT VALUES... C 1 = COMPUTE FUNCTION VALUE, I.E., V(F). C 2 = COMPUTE G. C 3 = DONE. C C C *** PARAMETER DECLARATIONS *** C INTEGER IRT, LIV, LV, P INTEGER IV(LIV) REAL B(2,P), D(P), G(P), V(LV), X(P) C C *** LOCAL VARIABLES *** C LOGICAL OFFSID INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2, 1 NEWM1, PP1O2, STPI, STPM, STP0 REAL DEL, DEL0, T, XM, XM1 REAL HALF, HLIM, ONE, TWO, ZERO C C *** EXTERNAL SUBROUTINES *** C EXTERNAL V7CPY, V7SCP C C V7CPY.... COPY ONE VECTOR TO ANOTHER. C V7SCP... COPY SCALAR TO ALL COMPONENTS OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE, 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE C PARAMETER (HALF=0.5E+0, HLIM=0.1E+0, ONE=1.E+0, TWO=2.E+0, 1 ZERO=0.E+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 V7SCP(P*(P+1)/2, V(HES), ZERO) 10 IF (M .GT. P) GO TO 999 IF (KIND .LT. 0) GO TO 120 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P IF (M .GT. 0) GO TO 20 C *** FIRST CALL ON F7DHB. SET GSAVE = G, TAKE FIRST STEP *** CALL V7CPY(P, V(GSAVE1), G) IV(SWITCH) = IV(NFGCAL) GO TO 80 C 20 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 30 C C *** HANDLE OVERSIZE V(DELTA) *** C DEL0 = V(DELTA0) * MAX(ONE/D(M), ABS(X(M))) DEL = HALF * DEL IF ( ABS(DEL/DEL0) .LE. HLIM) GO TO 140 C 30 HES = -IV(H) C C *** SET G = (G - GSAVE)/DEL *** C DEL = ONE / DEL DO 40 I = 1, P G(I) = DEL * (G(I) - V(GSAVE1)) GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = HES + M*(M-1)/2 L = K + M - 2 IF (M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C MM1 = M - 1 DO 50 I = 1, MM1 IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I)) K = K + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P IF (B(1,I) .LT. B(2,I)) V(L) = G(I) L = L + I 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 340 IF (B(1,M) .GE. B(2,M)) GO TO 80 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * MAX(ONE/D(M), ABS(X(M))) XM = X(M) IF (XM .LT. ZERO) GO TO 90 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 GO TO 280 90 XM1 = XM - DEL IF (XM1 .GE. B(1,M)) GO TO 100 XM1 = XM + DEL IF (XM1 .LE. B(2,M)) GO TO 110 GO TO 280 C 100 DEL = -DEL 110 V(XMSAVE) = XM X(M) = XM1 V(DELTA) = DEL IRT = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 120 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 HES = -IV(H) IF (M .GT. 0) GO TO 130 C *** FIRST CALL ON F7DHB. *** IV(SAVEI) = 0 GO TO 240 C 130 IF (IV(TOOBIG) .EQ. 0) GO TO 150 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** 140 IV(FDH) = -2 GO TO 350 150 I = IV(SAVEI) IF (I .GT. 0) GO TO 190 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C PP1O2 = P * (P-1) / 2 HPM = HES + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C NEWM1 = 1 GO TO 260 160 HMI = HES + MM1O2 IF (MM1 .EQ. 0) GO TO 180 HPI = HES + PP1O2 DO 170 I = 1, MM1 T = ZERO IF (B(1,I) .LT. B(2,I)) T = V(FX) - (V(F) + V(HPI)) V(HMI) = T HMI = HMI + 1 HPI = HPI + 1 170 CONTINUE 180 V(HMI) = V(F) - TWO*V(FX) IF (OFFSID) V(HMI) = V(FX) - TWO*V(F) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 0 GO TO 200 C 190 X(I) = V(DELTA) C C *** FINISH COMPUTING H(M,I) *** C STPI = STP0 + I HMI = HES + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) 200 I = I + 1 IF (I .GT. M) GO TO 230 IF (B(1,I) .LT. B(2,I)) GO TO 210 GO TO 200 C 210 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IRT = 1 IF (I .LT. M) GO TO 999 NEWM1 = 2 GO TO 260 220 X(M) = V(XMSAVE) - DEL IF (OFFSID) X(M) = V(XMSAVE) + TWO*DEL GO TO 999 C 230 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 240 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 330 IF (B(1,M) .LT. B(2,M)) GO TO 250 GO TO 240 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C 250 V(XMSAVE) = X(M) NEWM1 = 3 260 XM = V(XMSAVE) DEL = V(DLTFDC) * MAX(ONE/D(M), ABS(XM)) XM1 = XM + DEL OFFSID = .FALSE. IF (XM1 .LE. B(2,M)) GO TO 270 OFFSID = .TRUE. XM1 = XM - DEL IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300 GO TO 280 270 IF (XM-DEL .GE. B(1,M)) GO TO 290 OFFSID = .TRUE. IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310 C 280 IV(FDH) = -2 GO TO 350 C 290 IF (XM .GE. ZERO) GO TO 310 XM1 = XM - DEL 300 DEL = -DEL 310 GO TO (160, 220, 320), NEWM1 320 X(M) = XM1 STPM = STP0 + M V(STPM) = DEL IRT = 1 GO TO 999 C C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES C *** FROM LAST ROW OF FDH... C 330 IF (B(1,P) .LT. B(2,P)) GO TO 340 I = HES + P*(P-1)/2 CALL V7SCP(P, V(I), ZERO) C C *** RESTORE V(F), ETC. *** C 340 IV(FDH) = HES 350 V(F) = V(FX) IRT = 3 IF (KIND .LT. 0) GO TO 999 IV(NFGCAL) = IV(SWITCH) GSAVE1 = IV(W) + P CALL V7CPY(P, G, V(GSAVE1)) GO TO 999 C 999 RETURN C *** LAST LINE OF F7DHB FOLLOWS *** END SUBROUTINE G7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y) C C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR *** C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) *** C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) REAL B(2,P), D(P), G(P), V(LV), X(P), Y(P) C C-------------------------- PARAMETER USAGE -------------------------- C C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X. C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C LIV.. LENGTH OF IV. MUST BE AT LEAST 80. C LH... LENGTH OF H = P*(P+1)/2. C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7. C G.... GRADIENT AT X (WHEN IV(1) = 2). C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2). C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE). C C *** DISCUSSION *** C C G7ITB IS SIMILAR TO G7LIT, EXCEPT FOR THE EXTRA PARAMETER B C -- G7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), C I = 1(1)P. C G7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED C COMPACTLY BY ROWS), AND G7ITB BUILDS AN APPROXIMATION, S, TO THE C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE, C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S. C G7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO USE S WHEN CHOOSING C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL). C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN C COMPUTED HAS NONZERO VALUES IN THESE ROWS. C C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2, C 1, OR 2). C C FOR UPDATING S, G7ITB ASSUMES THAT THE GRADIENT HAS THE FORM C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP, C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY C PART OF THIS IN Y, NAMELY THE SUM OVER I OF C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING G7ITB WITH IV(1) = 2 AND C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART, C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF C GRAD(R(I,X)), STEP, AND Y. C C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING C ONES TO N2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT N2GB USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH N2GB (AND NL2SOL), IV(1) C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE C EXPLAINED BELOW, AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM C N2GB (AND N2FB), ARE NOT REFERENCED BY G7ITB OR THE C SUBROUTINES IT CALLS. C C WHEN G7ITB IS FIRST CALLED, I.E., WHEN G7ITB IS CALLED WITH C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO C OBTAIN THESE STARTING VALUES, G7ITB RETURNS FIRST WITH IV(1) = 1, C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.) C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE G7ITB WILL MAKE C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE. C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED. C C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE C FUNCTION VALUE AT X, AND CALL G7ITB AGAIN, HAVING CHANGED C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL C CAUSE G7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM- C PUTING G, HC, AND Y THE NEXT TIME G7ITB RETURNS WITH C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS. C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE. C THE CALLER SHOULD THEN CALL G7ITB AGAIN (WITH IV(1) = 2). C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS. C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET C IV(NFGCAL) TO 0, IN WHICH CASE G7ITB WILL RETURN WITH C IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL HAVQTR, HAVRM INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1, 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2, 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2, 3 TG1, W1, WLM1, X01 REAL E, GI, STTSST, T, T1, XI C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ONEP2, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C LOGICAL STOPX REAL D7TPR, RLDST, V2NRM EXTERNAL A7SST, D7TPR, F7DHB, G7QSB,I7COPY, I7PNVR, I7SHFT, 1 ITSUM, L7MSB, L7SQR, L7TVM, L7VML, PARCK, Q7RSH, 2 RLDST, S7DMP, S7IPR, S7LUP, S7LVM, STOPX, V2NRM, 3 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP C C A7SST.... ASSESSES CANDIDATE STEP. C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS. C F7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX). C G7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER. C I7PNVR... INVERTS PERMUTATION ARRAY. C I7SHFT... SHIFTS AN INTEGER VECTOR. C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X. C L7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C L7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L. C L7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX. C PARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS. C Q7RSH... SHIFTS A QR FACTORIZATION. C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE. C S7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX. C S7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX. C S7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C S7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C V2NRM... RETURNS THE 2-NORM OF A VECTOR. C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C V7CPY.... COPIES ONE VECTOR TO ANOTHER. C V7IPR... APPLIES A PERMUTATION TO A VECTOR. C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT, 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV, 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0, 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS, 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP, 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5, 8 VNEED, VSAVE, W, WSCALE, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.) C 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.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, 1 ZERO=0.E+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 PARCK(1, D, IV, LIV, LV, P, V) I = IV(1) - 2 IF (I .GT. 12) GO TO 999 GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I C C *** STORAGE ALLOCATION *** C 20 PP1O2 = P * (P + 1) / 2 IV(S) = IV(LMAT) + PP1O2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + 2*P IV(DIG) = IV(STEP) + 3*P IV(W) = IV(DIG) + 2*P IV(H) = IV(W) + 4*P + 7 IV(NEXTV) = IV(H) + PP1O2 IV(IPIVOT) = IV(PERM) + 3*P IV(NEXTIV) = IV(IPIVOT) + P IF (IV(1) .NE. 13) GO TO 30 IV(1) = 14 GO TO 999 C C *** INITIALIZATION *** C 30 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(RADINC) = 0 IV(PC) = P V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY *** C IPI = IV(IPIVOT) DO 40 I = 1, P IV(IPI) = I IPI = IPI + 1 IF (B(1,I) .GT. B(2,I)) GO TO 680 40 CONTINUE C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IV(1) = 1 IF (IV(S) .LT. 0) GO TO 710 IF (IV(INITS) .GT. 1) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2) 1 CALL V7SCP(P*(P+1)/2, V(S1), ZERO) GO TO 710 C C *** NEW FUNCTION VALUE *** C 50 IF (IV(MODE) .EQ. 0) GO TO 360 IF (IV(MODE) .GT. 0) GO TO 590 C IF (IV(TOOBIG) .EQ. 0) GO TO 690 IV(1) = 63 GO TO 999 C C *** MAKE SURE GRADIENT COULD BE COMPUTED *** C 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70 IV(1) = 65 GO TO 999 C C *** NEW GRADIENT *** C 70 IV(KALM) = -1 IV(KAGQT) = -1 IV(FDH) = 0 IF (IV(MODE) .GT. 0) GO TO 590 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670 C C *** CHOOSE INITIAL PERMUTATION *** C IPI = IV(IPIVOT) IPN = IPI + P - 1 IPIV2 = IV(PERM) - 1 K = IV(PC) P1 = P PP1 = P + 1 RMAT1 = IV(RMAT) HAVRM = RMAT1 .GT. 0 QTR1 = IV(QTR) HAVQTR = QTR1 .GT. 0 C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) *** W1 = IV(W) IF (.NOT. HAVQTR) QTR1 = W1 + P C DO 100 I = 1, P I1 = IV(IPN) IPN = IPN - 1 IF (B(1,I1) .GE. B(2,I1)) GO TO 80 XI = X(I1) GI = G(I1) IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80 IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80 C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED *** J = IPIV2 + I1 IF (IV(J) .GT. K) IV(CNVCOD) = 0 GO TO 100 80 IF (I1 .GE. P1) GO TO 90 I1 = PP1 - I CALL I7SHFT(P1, I1, IV(IPI)) IF (HAVRM) 1 CALL Q7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1)) 90 P1 = P1 - 1 100 CONTINUE IV(PC) = P1 C C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) *** C V(DGNORM) = ZERO IF (P1 .LE. 0) GO TO 110 DIG1 = IV(DIG) CALL V7VMP(P, V(DIG1), G, D, -1) CALL V7IPR(P, IV(IPI), V(DIG1)) V(DGNORM) = V2NRM(P1, V(DIG1)) 110 IF (IV(CNVCOD) .NE. 0) GO TO 580 IF (IV(MODE) .EQ. 0) GO TO 510 IV(MODE) = 0 V(F0) = V(F) IF (IV(INITS) .LE. 2) GO TO 170 C C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S *** C IV(XIRC) = IV(COVREQ) IV(COVREQ) = -1 IF (IV(INITS) .GT. 3) IV(COVREQ) = 1 IV(CNVCOD) = 70 GO TO 600 C C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S *** C 120 H1 = IV(FDH) IF (H1 .LE. 0) GO TO 660 IV(CNVCOD) = 0 IV(MODE) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(COVREQ) = IV(XIRC) S1 = IV(S) PP1O2 = PS * (PS + 1) / 2 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 130 CALL V2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1)) GO TO 140 130 RMAT1 = IV(RMAT) LMAT1 = IV(LMAT) CALL L7SQR(P, V(LMAT1), V(RMAT1)) IPI = IV(IPIVOT) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPI)) CALL S7IPR(P, IV(IPIV1), V(LMAT1)) CALL V2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1)) C C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS *** C 140 DO 160 I = 1, P IF (B(1,I) .LT. B(2,I)) GO TO 160 K = S1 + I*(I-1)/2 CALL V7SCP(I, V(K), ZERO) IF (I .GE. P) GO TO 170 K = K + 2*I - 1 I1 = I + 1 DO 150 J = I1, P V(K) = ZERO K = K + J 150 CONTINUE 160 CONTINUE C 170 IV(1) = 2 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 180 CALL ITSUM(D, G, IV, LIV, LV, P, V, X) 190 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 200 IV(1) = 10 GO TO 999 200 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 220 STEP1 = IV(STEP) DO 210 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 210 CONTINUE STEP1 = IV(STEP) T = V(RADFAC) * V2NRM(P, V(STEP1)) IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 220 X01 = IV(X0) V(F0) = V(F) IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL V7CPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 230 IF (.NOT. STOPX(DUMMY)) GO TO 250 IV(1) = 11 GO TO 260 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 240 IF (V(F) .GE. V(F0)) GO TO 250 V(RADFAC) = ONE K = IV(NITER) GO TO 200 C 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270 IV(1) = 9 260 IF (V(F) .GE. V(F0)) GO TO 999 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 500 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 270 STEP1 = IV(STEP) TG1 = IV(DIG) TD1 = TG1 + P X01 = IV(X0) W1 = IV(W) H1 = IV(H) P1 = IV(PC) IPI = IV(PERM) IPIV1 = IPI + P IPIV2 = IPIV1 + P IPIV0 = IV(IPIVOT) IF (IV(MODEL) .EQ. 2) GO TO 280 C C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE... C RMAT1 = IV(RMAT) IF (RMAT1 .LE. 0) GO TO 280 QTR1 = IV(QTR) IF (QTR1 .LE. 0) GO TO 280 LMAT1 = IV(LMAT) WLM1 = W1 + P CALL L7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1), 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0), 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1), 3 V(TG1), V, V(W1), V(WLM1), X, V(X01)) C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN, C *** SO WE MARK IT INVALID... IV(H) = -IABS(H1) C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO C *** MARK INVALID THE INFORMATION G7QTS MAY HAVE STORED IN V... IV(KAGQT) = -1 GO TO 330 C 280 IF (H1 .GT. 0) GO TO 320 C C *** SET H TO D**-1 * (HC + T1*S) * D**-1. *** C P1LEN = P1*(P1+1)/2 H1 = -H1 IV(H) = H1 IV(FDH) = 0 IF (P1 .LE. 0) GO TO 320 C *** MAKE TEMPORARY PERMUTATION ARRAY *** CALL I7COPY(P, IV(IPI), IV(IPIV0)) J = IV(HC) IF (J .GT. 0) GO TO 290 J = H1 RMAT1 = IV(RMAT) CALL L7SQR(P1, V(H1), V(RMAT1)) GO TO 300 290 CALL V7CPY(P*(P+1)/2, V(H1), V(J)) CALL S7IPR(P, IV(IPI), V(H1)) 300 IF (IV(MODEL) .EQ. 1) GO TO 310 LMAT1 = IV(LMAT) S1 = IV(S) CALL V7CPY(P*(P+1)/2, V(LMAT1), V(S1)) CALL S7IPR(P, IV(IPI), V(LMAT1)) CALL V2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1)) 310 CALL V7CPY(P, V(TD1), D) CALL V7IPR(P, IV(IPI), V(TD1)) CALL S7DMP(P1, V(H1), V(H1), V(TD1), -1) IV(KAGQT) = -1 C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 320 LMAT1 = IV(LMAT) CALL G7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2), 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1), 2 V(TD1), V(TG1), V, V(W1), X, V(X01)) IF (IV(KALM) .GT. 0) IV(KALM) = 0 C 330 IF (IV(IRC) .NE. 6) GO TO 340 IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 2 GO TO 370 C C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE *** C 340 IV(TOOBIG) = 0 IF (V(DSTNRM) .LE. ZERO) GO TO 360 IF (IV(IRC) .NE. 5) GO TO 350 IF (V(RADFAC) .LE. ONE) GO TO 350 IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350 IF (IV(RESTOR) .NE. 2) GO TO 360 RSTRST = 0 GO TO 370 C C *** COMPUTE F(X0 + STEP) *** C 350 X01 = IV(X0) STEP1 = IV(STEP) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 360 RSTRST = 3 370 X01 = IV(X0) V(RELDX) = RLDST(P, D, X, V(X01)) CALL A7SST(IV, LIV, LV, V) STEP1 = IV(STEP) LSTGST = X01 + P I = IV(RESTOR) + 1 GO TO (410, 380, 390, 400), I 380 CALL V7CPY(P, X, V(X01)) GO TO 410 390 CALL V7CPY(P, V(LSTGST), V(STEP1)) GO TO 410 400 CALL V7CPY(P, V(STEP1), V(LSTGST)) CALL V2AXY(P, X, ONE, V(STEP1), V(X01)) V(RELDX) = RLDST(P, D, X, V(X01)) C C *** IF NECESSARY, SWITCH MODELS *** C 410 IF (IV(SWITCH) .EQ. 0) GO TO 420 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V, V(L)) 420 CALL V2AXY(P, V(STEP1), NEGONE, V(X01), X) L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) S1 = IV(S) CALL S7LVM(PS, Y, V(S1), V(STEP1)) STTSST = HALF * D7TPR(PS, V(STEP1), Y) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 430 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (-2 .LT. L) GO TO 470 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 L = IV(VSAVE) CALL V7CPY(NVSAVE, V(L), V) GO TO 230 C 430 IF (-3 .LT. L) GO TO 470 C C *** RECOMPUTE STEP WITH DIFFERENT RADIUS *** C 440 V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 230 C C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST C 450 V(RADIUS) = V(LMAXS) GO TO 270 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 460 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 580 IF (IV(XIRC) .EQ. 14) GO TO 580 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 470 IV(COVMAT) = 0 IV(REGD) = 0 C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C IF (IV(IRC) .NE. 3) GO TO 500 STEP1 = IV(STEP) TEMP1 = STEP1 + P TEMP2 = IV(X0) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 480 CALL S7LVM(P, V(TEMP1), V(HC1), V(STEP1)) GO TO 490 480 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL V7CPY(P, V(TEMP1), V(STEP1)) CALL V7IPR(P, IV(IPIV0), V(TEMP1)) CALL L7TVM(P, V(TEMP1), V(RMAT1), V(TEMP1)) CALL L7VML(P, V(TEMP1), V(RMAT1), V(TEMP1)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL V7IPR(P, IV(IPIV1), V(TEMP1)) C 490 IF (STPMOD .EQ. 1) GO TO 500 S1 = IV(S) CALL S7LVM(PS, V(TEMP2), V(S1), V(STEP1)) CALL V2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1)) C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 500 IV(NGCALL) = IV(NGCALL) + 1 G01 = IV(W) CALL V7CPY(P, V(G01), G) GO TO 690 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 510 G01 = IV(W) CALL V2AXY(P, V(G01), NEGONE, V(G01), G) STEP1 = IV(STEP) TEMP1 = STEP1 + P TEMP2 = IV(X0) IF (IV(IRC) .NE. 3) GO TO 540 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 520 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 520 CONTINUE C C *** DO GRADIENT TESTS *** C IF ( V2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 530 IF ( D7TPR(P, G, V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 540 530 V(RADFAC) = V(INCFAC) C C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S *** C 540 CALL V2AXY(PS, Y, NEGONE, Y, G) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL S7LVM(PS, V(TEMP1), V(S1), V(STEP1)) C T1 = ABS( D7TPR(PS, V(STEP1), V(TEMP1))) T = ABS( D7TPR(PS, V(STEP1), Y)) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI *** C HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 550 CALL S7LVM(PS, V(G01), V(HC1), V(STEP1)) GO TO 560 C 550 RMAT1 = IV(RMAT) IPIV0 = IV(IPIVOT) CALL V7CPY(P, V(G01), V(STEP1)) I = G01 + PS IF (PS .LT. P) CALL V7SCP(P-PS, V(I), ZERO) CALL V7IPR(P, IV(IPIV0), V(G01)) CALL L7TVM(P, V(G01), V(RMAT1), V(G01)) CALL L7VML(P, V(G01), V(RMAT1), V(G01)) IPIV1 = IV(PERM) + P CALL I7PNVR(P, IV(IPIV1), IV(IPIV0)) CALL V7IPR(P, IV(IPIV1), V(G01)) C 560 CALL V2AXY(PS, V(G01), ONE, Y, V(G01)) C C *** UPDATE S *** C CALL S7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), Y) IV(1) = 2 GO TO 180 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 570 IV(1) = 64 GO TO 999 C C C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE *** C 580 IF (IV(RDREQ) .EQ. 0) GO TO 660 IF (IV(FDH) .NE. 0) GO TO 660 IF (IV(CNVCOD) .GE. 7) GO TO 660 IF (IV(REGD) .GT. 0) GO TO 660 IF (IV(COVMAT) .GT. 0) GO TO 660 IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640 IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2 GO TO 600 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE *** C 590 IV(RESTOR) = 0 600 CALL F7DHB(B, D, G, I, IV, LIV, LV, P, V, X) GO TO (610, 620, 630), I 610 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 GO TO 710 C 620 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(NFGCAL) = IV(NFCALL) + IV(NGCOV) GO TO 690 C 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120 GO TO 660 C 640 H1 = IABS(IV(H)) IV(FDH) = H1 IV(H) = -H1 HC1 = IV(HC) IF (HC1 .LE. 0) GO TO 650 CALL V7CPY(P*(P+1)/2, V(H1), V(HC1)) GO TO 660 650 RMAT1 = IV(RMAT) CALL L7SQR(P, V(H1), V(RMAT1)) C 660 IV(MODE) = 0 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 GO TO 999 C C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0 C 670 IV(1) = 1400 GO TO 999 C C *** INCONSISTENT B *** C 680 IV(1) = 82 GO TO 999 C C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G *** C 690 IV(1) = 2 J = IV(IPIVOT) IPI = IV(PERM) CALL I7PNVR(P, IV(IPI), IV(J)) DO 700 I = 1, P IV(J) = I J = J + 1 700 CONTINUE C C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) *** C 710 DO 720 I = 1, P IF (X(I) .LT. B(1,I)) X(I) = B(1,I) IF (X(I) .GT. B(2,I)) X(I) = B(2,I) 720 CONTINUE IV(TOOBIG) = 0 C 999 RETURN C C *** LAST LINE OF G7ITB FOLLOWS *** END SUBROUTINE G7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV, 1 P, P0, PC, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) REAL B(2,P), D(P), DIHDI(1), G(P), L(1), 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2) C REAL D7TPR EXTERNAL D7TPR, G7QTS, S7BQN, S7IPR, V7CPY, V7IPR, 1 V7SCP, V7VMP C C *** LOCAL VARIABLES *** C INTEGER K, KB, KINIT, NS, P1, P10 REAL DS0, NRED, PRED, RAD REAL ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) DATA ZERO/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C P1 = PC IF (KA .LT. 0) GO TO 10 NRED = V(NREDUC) DS0 = V(DST0) GO TO 20 10 P0 = 0 KA = -1 C 20 KINIT = -1 IF (P0 .EQ. P1) KINIT = KA CALL V7CPY(P, X, X0) PRED = ZERO RAD = V(RADIUS) KB = -1 V(DSTNRM) = ZERO IF (P1 .GT. 0) GO TO 30 NRED = ZERO DS0 = ZERO CALL V7SCP(P, STEP, ZERO) GO TO 60 C 30 CALL V7CPY(P, TD, D) CALL V7IPR(P, IPIV, TD) CALL V7VMP(P, TG, G, D, -1) CALL V7IPR(P, IPIV, TG) 40 K = KINIT KINIT = -1 V(RADIUS) = RAD - V(DSTNRM) CALL G7QTS(TD, TG, DIHDI, K, L, P1, STEP, V, W) P0 = P1 IF (KA .GE. 0) GO TO 50 NRED = V(NREDUC) DS0 = V(DST0) C 50 KA = K V(RADIUS) = RAD P10 = P1 CALL S7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, L, LV, 1 NS, P, P1, STEP, TD, TG, V, W, X, X0) IF (NS .GT. 0) CALL S7IPR(P10, IPIV1, DIHDI) PRED = PRED + V(PREDUC) IF (NS .NE. 0) P0 = 0 IF (KB .LE. 0) GO TO 40 C 60 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = D7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF G7QSB FOLLOWS *** END SUBROUTINE H2RFA(N, A, B, X, Y, Z) C C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO C *** N-VECTORS A, B *** C INTEGER N REAL A(N), B(N), X, Y, Z INTEGER I REAL T DO 10 I = 1, N T = A(I)*X + B(I)*Y A(I) = A(I) + T B(I) = B(I) + T*Z 10 CONTINUE 999 RETURN C *** LAST LINE OF H2RFA FOLLOWS *** END REAL FUNCTION H2RFG(A, B, X, Y, Z) C C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2 C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T, C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE H2RFG C *** RETURNS. C REAL A, B, X, Y, Z C REAL A1, B1, C, T REAL ZERO DATA ZERO/0.E+0/ C C *** BODY *** C IF (B .NE. ZERO) GO TO 10 X = ZERO Y = ZERO Z = ZERO H2RFG = A GO TO 999 10 T = ABS(A) + ABS(B) A1 = A / T B1 = B / T C = SQRT(A1**2 + B1**2) IF (A1 .GT. ZERO) C = -C A1 = A1 - C Z = B1 / A1 X = A1 / C Y = B1 / C H2RFG = T * C 999 RETURN C *** LAST LINE OF H2RFG FOLLOWS *** END SUBROUTINE L7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT, 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V, 2 W, WLM, X, X0) C C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP *** C INTEGER IERR, KA, LV, P, P0, PC INTEGER IPIV(P), IPIV1(P), IPIV2(P) REAL B(2,P), D(P), G(P), LMAT(1), QTR(P), RMAT(1), 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(1), 2 X0(P), X(P) C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4) C REAL D7TPR EXTERNAL D7MLP, D7TPR, L7MST, L7TVM, Q7RSH, S7BQN, 1 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP C C *** LOCAL VARIABLES *** C INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11 REAL DS0, NRED, PRED, RAD REAL ONE, ZERO C C *** V SUBSCRIPTS *** C INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS C PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7, 1 RADIUS=8) DATA ONE/1.E+0/, ZERO/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C P1 = PC IF (KA .LT. 0) GO TO 10 NRED = V(NREDUC) DS0 = V(DST0) GO TO 20 10 P0 = 0 KA = -1 C 20 KINIT = -1 IF (P0 .EQ. P1) KINIT = KA CALL V7CPY(P, X, X0) CALL V7CPY(P, TD, D) C *** USE STEP(1,3) AS TEMP. COPY OF QTR *** CALL V7CPY(P, STEP(1,3), QTR) CALL V7IPR(P, IPIV, TD) PRED = ZERO RAD = V(RADIUS) KB = -1 V(DSTNRM) = ZERO IF (P1 .GT. 0) GO TO 30 NRED = ZERO DS0 = ZERO CALL V7SCP(P, STEP, ZERO) GO TO 90 C 30 CALL V7VMP(P, TG, G, D, -1) CALL V7IPR(P, IPIV, TG) P10 = P1 40 K = KINIT KINIT = -1 V(RADIUS) = RAD - V(DSTNRM) CALL V7VMP(P1, TG, TG, TD, 1) DO 50 I = 1, P1 50 IPIV1(I) = I K0 = MAX0(0, K) CALL L7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP, 1 V, WLM) CALL V7VMP(P1, TG, TG, TD, -1) P0 = P1 IF (KA .GE. 0) GO TO 60 NRED = V(NREDUC) DS0 = V(DST0) C 60 KA = K V(RADIUS) = RAD L = P1 + 5 IF (K .LE. K0) CALL D7MLP(P1, LMAT, TD, RMAT, -1) IF (K .GT. K0) CALL D7MLP(P1, LMAT, TD, WLM(L), -1) CALL S7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT, 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0) PRED = PRED + V(PREDUC) IF (NS .EQ. 0) GO TO 80 P0 = 0 C C *** UPDATE RMAT AND QTR *** C P11 = P1 + 1 L = P10 + P11 DO 70 K = P11, P10 J = L - K I = IPIV2(J) IF (I .LT. J) CALL Q7RSH(I, J, .TRUE., QTR, RMAT, W) 70 CONTINUE C 80 IF (KB .GT. 0) GO TO 90 C C *** UPDATE LOCAL COPY OF QTR *** C CALL V7VMP(P10, W, STEP(1,2), TD, -1) CALL L7TVM(P10, W, LMAT, W) CALL V2AXY(P10, STEP(1,3), ONE, W, QTR) GO TO 40 C 90 V(DST0) = DS0 V(NREDUC) = NRED V(PREDUC) = PRED V(GTSTEP) = D7TPR(P, G, STEP) C 999 RETURN C *** LAST LINE OF L7MSB FOLLOWS *** END SUBROUTINE Q7RSH(K, P, HAVQTR, QTR, R, W) C C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY *** C LOGICAL HAVQTR INTEGER K, P REAL QTR(P), R(1), W(P) C DIMSNSION R(P*(P+1)/2) C REAL H2RFG EXTERNAL H2RFA, H2RFG, V7CPY C C *** LOCAL VARIABLES *** C INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1 REAL A, B, T, WJ, X, Y, Z, ZERO C DATA ZERO/0.0E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C IF (K .GE. P) GO TO 999 KM1 = K - 1 K1 = K * KM1 / 2 CALL V7CPY(K, W, R(K1+1)) WJ = W(K) PM1 = P - 1 J1 = K1 + KM1 DO 50 J = K, PM1 JM1 = J - 1 JP1 = J + 1 IF (JM1 .GT. 0) CALL V7CPY(JM1, R(K1+1), R(J1+2)) J1 = J1 + JP1 K1 = K1 + J A = R(J1) B = R(J1+1) IF (B .NE. ZERO) GO TO 10 R(K1) = A X = ZERO Z = ZERO GO TO 40 10 R(K1) = H2RFG(A, B, X, Y, Z) IF (J .EQ. PM1) GO TO 30 I1 = J1 DO 20 I = JP1, PM1 I1 = I1 + I CALL H2RFA(1, R(I1), R(I1+1), X, Y, Z) 20 CONTINUE 30 IF (HAVQTR) CALL H2RFA(1, QTR(J), QTR(JP1), X, Y, Z) 40 T = X * WJ W(J) = WJ + T WJ = T * Z 50 CONTINUE W(P) = WJ CALL V7CPY(P, R(K1+1), W) 999 RETURN END SUBROUTINE S7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS, 1 P, P1, STEP, TD, TG, V, W, X, X0) C C *** COMPUTE BOUNDED MODIFIED NEWTON STEP *** C INTEGER KB, LV, NS, P, P1 INTEGER IPIV(P), IPIV1(P), IPIV2(P) REAL B(2,P), D(P), DST(P), L(1), 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P), 2 X0(P) C DIMENSION L(P*(P+1)/2) C REAL D7TPR, R7MDC, V2NRM EXTERNAL D7TPR, I7SHFT, L7ITV, L7IVM, Q7RSH, R7MDC, V2NRM, 1 V2AXY, V7CPY, V7IPR, V7SCP, V7SHF C C *** LOCAL VARIABLES *** C INTEGER I, J, K, P0, P1M1 REAL ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T, 1 TI, T1, XI REAL FUDGE, HALF, MEPS2, ONE, TWO, ZERO C C *** V SUBSCRIPTS *** C INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR C PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7, 1 RADIUS=8, STPPAR=5) SAVE MEPS2 C DATA FUDGE/1.0001E+0/, HALF/0.5E+0/, MEPS2/0.E+0/, 1 ONE/1.0E+0/, TWO/2.E+0/, ZERO/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C DSTMAX = FUDGE * (ONE + V(PHMXFC)) * V(RADIUS) DSTMIN = (ONE + V(PHMNFC)) * V(RADIUS) DST1 = ZERO IF (MEPS2 .LE. ZERO) MEPS2 = TWO * R7MDC(3) P0 = P1 NS = 0 DO 10 I = 1, P IPIV1(I) = I IPIV2(I) = I 10 CONTINUE DO 20 I = 1, P1 20 W(I) = -STEP(I) * TD(I) ALPHA = ABS(V(STPPAR)) V(PREDUC) = ZERO GTS = -V(GTSTEP) IF (KB .LT. 0) CALL V7SCP(P, DST, ZERO) KB = 1 C C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D. C C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE. C 30 T = ONE K = 0 DO 60 I = 1, P1 J = IPIV(I) DX = W(I) / D(J) XI = X(J) - DX IF (XI .LT. B(1,J)) GO TO 40 IF (XI .LE. B(2,J)) GO TO 60 TI = ( X(J) - B(2,J) ) / DX K = I GO TO 50 40 TI = ( X(J) - B(1,J) ) / DX K = -I 50 IF (T .LE. TI) GO TO 60 T = TI 60 CONTINUE C IF (P .GT. P1) CALL V7CPY(P-P1, STEP(P1+1), DST(P1+1)) CALL V2AXY(P1, STEP, -T, W, DST) DST0 = DST1 DST1 = V2NRM(P, STEP) C C *** CHECK FOR OVERSIZE STEP *** C IF (DST1 .LE. DSTMAX) GO TO 80 IF (P1 .GE. P0) GO TO 70 IF (DST0 .LT. DSTMIN) KB = 0 GO TO 110 C 70 K = 0 C C *** UPDATE DST, TG, AND V(PREDUC) *** C 80 V(DSTNRM) = DST1 CALL V7CPY(P1, DST, STEP) T1 = ONE - T DO 90 I = 1, P1 90 TG(I) = T1 * TG(I) IF (ALPHA .GT. ZERO) CALL V2AXY(P1, TG, T*ALPHA, W, TG) V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS + 1 HALF*ALPHA*T* D7TPR(P1,W,W)) IF (K .EQ. 0) GO TO 110 C C *** PERMUTE L, ETC. IF NECESSARY *** C P1M1 = P1 - 1 J = IABS(K) IF (J .EQ. P1) GO TO 100 NS = NS + 1 IPIV2(P1) = J CALL Q7RSH(J, P1, .FALSE., TG, L, W) CALL I7SHFT(P1, J, IPIV) CALL I7SHFT(P1, J, IPIV1) CALL V7SHF(P1, J, TG) CALL V7SHF(P1, J, DST) 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1) P1 = P1M1 IF (P1 .LE. 0) GO TO 110 CALL L7IVM(P1, W, L, TG) GTS = D7TPR(P1, W, W) CALL L7ITV(P1, W, L, W) GO TO 30 C C *** UNSCALE STEP *** C 110 DO 120 I = 1, P J = IABS(IPIV(I)) STEP(J) = DST(I) / D(J) 120 CONTINUE C C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS C *** TO THEIR BOUNDS *** C IF (P1 .GE. P0) GO TO 150 K = P1 + 1 DO 140 I = K, P0 J = IPIV(I) T = MEPS2 IF (J .GT. 0) GO TO 130 T = -T J = -J IPIV(I) = J 130 T = T * MAX( ABS(X(J)), ABS(X0(J))) STEP(J) = STEP(J) + T 140 CONTINUE C 150 CALL V2AXY(P, X, ONE, STEP, X0) IF (NS .GT. 0) CALL V7IPR(P0, IPIV1, TD) 999 RETURN C *** LAST LINE OF S7BQN FOLLOWS *** END SUBROUTINE S7DMP(N, X, Y, Z, K) C C *** SET X = DIAG(Z)**K * Y * DIAG(Z)**K C *** FOR X, Y = COMPACTLY STORED LOWER TRIANG. MATRICES C *** K = 1 OR -1. C INTEGER N, K REAL X(*), Y(*), Z(N) INTEGER I, J, L REAL ONE, T DATA ONE/1.E+0/ C L = 1 IF (K .GE. 0) GO TO 30 DO 20 I = 1, N T = ONE / Z(I) DO 10 J = 1, I X(L) = T * Y(L) / Z(J) L = L + 1 10 CONTINUE 20 CONTINUE GO TO 999 C 30 DO 50 I = 1, N T = Z(I) DO 40 J = 1, I X(L) = T * Y(L) * Z(J) L = L + 1 40 CONTINUE 50 CONTINUE 999 RETURN C *** LAST LINE OF S7DMP FOLLOWS *** END SUBROUTINE S7IPR(P, IP, H) C C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H. C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)). C INTEGER P INTEGER IP(P) REAL H(1) C INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M REAL T C C *** BODY *** C DO 90 I = 1, P J = IP(I) IF (J .EQ. I) GO TO 90 IP(I) = IABS(J) IF (J .LT. 0) GO TO 90 K = I 10 J1 = J K1 = K IF (J .LE. K) GO TO 20 J1 = K K1 = J 20 KMJ = K1-J1 L = J1-1 JM = J1*L/2 KM = K1*(K1-1)/2 IF (L .LE. 0) GO TO 40 DO 30 M = 1, L JM = JM+1 T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 30 CONTINUE 40 KM = KM+1 KK = KM+KMJ JM = JM+1 T = H(JM) H(JM) = H(KK) H(KK) = T J1 = L L = KMJ-1 IF (L .LE. 0) GO TO 60 DO 50 M = 1, L JM = JM+J1+M T = H(JM) KM = KM+1 H(JM) = H(KM) H(KM) = T 50 CONTINUE 60 IF (K1 .GE. P) GO TO 80 L = P-K1 K1 = K1-1 KM = KK DO 70 M = 1, L KM = KM+K1+M JM = KM-KMJ T = H(JM) H(JM) = H(KM) H(KM) = T 70 CONTINUE 80 K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 10 90 CONTINUE 999 RETURN C *** LAST LINE OF S7IPR FOLLOWS *** END SUBROUTINE V7IPR(N, IP, X) C C PERMUTE X SO THAT X.OUTPUT(I) = X.INPUT(IP(I)). C IP IS UNCHANGED ON OUTPUT. C INTEGER N INTEGER IP(N) REAL X(N) C INTEGER I, J, K REAL T DO 30 I = 1, N J = IP(I) IF (J .EQ. I) GO TO 30 IF (J .GT. 0) GO TO 10 IP(I) = -J GO TO 30 10 T = X(I) K = I 20 X(K) = X(J) K = J J = IP(K) IP(K) = -J IF (J .GT. I) GO TO 20 X(K) = T 30 CONTINUE 999 RETURN C *** LAST LINE OF V7IPR FOLLOWS *** END SUBROUTINE V7SHF(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION *** C INTEGER N, K REAL X(N) C INTEGER I, NM1 REAL T C IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T 999 RETURN END SUBROUTINE V7VMP(N, X, Y, Z, K) C C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) *** C INTEGER N, K REAL X(N), Y(N), Z(N) INTEGER I C IF (K .GE. 0) GO TO 20 DO 10 I = 1, N 10 X(I) = Y(I) / Z(I) GO TO 999 C 20 DO 30 I = 1, N 30 X(I) = Y(I) * Z(I) 999 RETURN C *** LAST LINE OF V7VMP FOLLOWS *** END SUBROUTINE I7COPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE INTEGER P-VECTORS *** C INTEGER P INTEGER X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) 999 RETURN END SUBROUTINE I7PNVR(N, X, Y) C C *** SET PERMUTATION VECTOR X TO INVERSE OF Y *** C INTEGER N INTEGER X(N), Y(N) C INTEGER I, J DO 10 I = 1, N J = Y(I) X(J) = I 10 CONTINUE C 999 RETURN C *** LAST LINE OF I7PNVR FOLLOWS *** END SUBROUTINE I7SHFT(N, K, X) C C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION *** C INTEGER N, K INTEGER X(N) C INTEGER I, NM1, T C IF (K .GE. N) GO TO 999 NM1 = N - 1 T = X(K) DO 10 I = K, NM1 10 X(I) = X(I+1) X(N) = T 999 RETURN END //GO.SYSIN DD sglfgb.f cat >sgletc.f <<'//GO.SYSIN DD sgletc.f' SUBROUTINE A7SST(IV, LIV, LV, V) C C *** ASSESS CANDIDATE STEP (***SOL VERSION 2.3) *** C INTEGER LIV, LV INTEGER IV(LIV) REAL V(LV) C C *** PURPOSE *** C C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM- C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING C BELOW. C C-------------------------- PARAMETER USAGE -------------------------- C C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF IV VALUES REFERENCED. C LIV (IN) LENGTH OF IV ARRAY. C LV (IN) LENGTH OF V ARRAY. C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF V VALUES REFERENCED. C C *** IV VALUES REFERENCED *** C C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION, C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE C UNCHANGED SINCE THE PREVIOUS RETURN OF A7SST. C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE C FOLLOWING VALUES... C 1 = SWITCH MODELS OR TRY SMALLER STEP. C 2 = SWITCH MODELS OR ACCEPT STEP. C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT C TESTS. C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED. C 5 = RECOMPUTE STEP (USING THE SAME MODEL). C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT C EVAULATE 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 PRECDENCE OVER I+1 FOR I = 9, 10, 11. C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL). C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION. C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION, C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT. C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION. C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED. C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER C OF DECREASES) SO FAR THIS ITERATION. C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE C RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED, C TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO C 0 OTHERWISE. C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE C CURRENT ITERATION. C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER. C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL, C IN WHICH CASE A7SST SETS IV(SWITCH) = 1. C IV(TOOBIG) (IN) IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED C OVERFLOW). C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS. C C *** V VALUES REFERENCED *** C C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS C THAN V(AFCTOL) AND A7SST DOES NOT RETURN WITH C IV(IRC) = 11, THEN A7SST RETURNS WITH IV(IRC) = 10. C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS C NONZERO. C V(DSTNRM) (IN) THE 2-NORM OF D*STEP. C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP. C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED, C I.E., FOR V(NREDUC) .GE. 0). C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC- C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE, C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE. C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE). C V(FLSTGD) (I/O) SAVED VALUE OF V(F). C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION. C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP. C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT. C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS. C V(LMAXS) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND). C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9 C DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT C STEP IS A NEWTON STEP, AND IF C V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN A7SST RETURNS C WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, THEN C A7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP) C WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS) C (BY A RETURN WITH IV(IRC) = 6). C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C NEWTON STEP. IF A7SST IS CALLED WITH IV(IRC) = 6, I.E., C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR C USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED. C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP. C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C CURRENT STEP. C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS, C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED. C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1. C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0. C V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED C (E.G.) BY FUNCTION RLDST AS C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P). C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE- C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN C A7SST RETURNS WITH IV(IRC) = 8 OR 9. C V(SCTOL) (IN) SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS). C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP. C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED C VALUE = 0.1. C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED C VALUE = 10**-4. C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75. C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN C A7SST RETURNS IV(IRC) = 7 OR 9. C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL), C THEN A7SST RETURNS WITH IV(IRC) = 12. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER, C OR LEVENBERG-MARQUARDT STEPS. C C *** ALGORITHM NOTES *** C C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS, C A7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS. C C *** USAGE NOTES *** C C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O C VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER- C ANCES SHOULD BE CHANGED. C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN C CHANGE THE STOPPING TOLERANCES AND CALL A7SST AGAIN, IN WHICH C CASE THE STOPPING TESTS WILL BE REPEATED. C C *** REFERENCES *** C C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3. C C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** HISTORY *** C C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY. C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS C PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR C CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** NO EXTERNAL FUNCTIONS AND SUBROUTINES *** C C-------------------------- LOCAL VARIABLES -------------------------- C LOGICAL GOODX INTEGER I, NFC REAL EMAX, EMAXS, GTS, RFAC1, XMAX REAL HALF, ONE, ONEP2, TWO, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0, 1 GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL, 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN, 3 RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM, 4 STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, 5 XFTOL, XIRC C C *** DATA INITIALIZATIONS *** C PARAMETER (HALF=0.5E+0, ONE=1.E+0, ONEP2=1.2E+0, TWO=2.E+0, 1 ZERO=0.E+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) 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 110 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 110 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 110, 110, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 IV(RESTOR) = 1 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 IV(RESTOR) = 1 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) NFC = IV(NFGCAL) GOODX = .FALSE. 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 * MAX(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 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) = MAX(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) .NE. 1) IV(RESTOR) = 2 V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 230 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 210 V(RADFAC) = ONE IV(IRC) = 3 GO TO 230 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 220 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 240 IV(IRC) = 12 GO TO 240 C C *** PERFORM CONVERGENCE TESTS *** C 230 IV(XIRC) = IV(IRC) 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3 IF ( ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = V(RFCTOL) * ABS(V(F0)) EMAXS = V(SCTOL) * ABS(V(F0)) IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR. 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 250 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL) 1 .AND. GOODX) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR C *** CONVERGENCE TEST. C 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(STPPAR) .EQ. ZERO) GO TO 999 IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260 IF (V(PREDUC) .GE. EMAXS) GO TO 999 IF (V(DST0) .LE. ZERO) GO TO 270 IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999 GO TO 270 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999 XMAX = V(LMAXS) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999 270 IF (V(NREDUC) .LT. ZERO) GO TO 290 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) I = IV(RESTOR) IV(RESTOR) = 2 IF (I .EQ. 3) IV(RESTOR) = 0 IV(IRC) = 6 GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 280 V(GTSTEP) = V(GTSLST) V(DSTNRM) = ABS(V(DSTSAV)) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) IV(RESTOR) = 3 290 IF (-V(NREDUC) .LE. V(SCTOL) * ABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST LINE OF A7SST FOLLOWS *** END REAL FUNCTION D7TPR(P, X, Y) C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C INTEGER P REAL X(P), Y(P) C INTEGER I REAL R7MDC EXTERNAL R7MDC C *** ACTIVATE THE *'ED COMMENT LINES BELOW IF UNDERFLOW IS A PROBLEM. C *** R7MDC(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C REAL ONE, ZERO PARAMETER (ONE=1.E+0, ZERO=0.E+0) * REAL SQTETA, T * DATA SQTETA/0.E+0/ C D7TPR = ZERO * IF (P .LE. 0) GO TO 999 * IF (SQTETA .EQ. ZERO) SQTETA = R7MDC(2) DO 20 I = 1, P * T = AMAX1( ABS(X(I)), ABS(Y(I))) * IF (T .GT. ONE) GO TO 10 * IF (T .LT. SQTETA) GO TO 20 * T = (X(I)/SQTETA)*Y(I) * IF ( ABS(T) .LT. SQTETA) GO TO 20 10 D7TPR = D7TPR + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST LINE OF D7TPR FOLLOWS *** END SUBROUTINE D7UP5(D, IV, LIV, LV, P, PS, V) C C *** UPDATE SCALE VECTOR D FOR G7LIT *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P, PS INTEGER IV(LIV) REAL D(P), V(LV) C C *** LOCAL VARIABLES *** C INTEGER D0, HII, I, JTOLI, JTOL0, R1I, S1 REAL T, VDFAC C C *** CONSTANTS *** REAL ZERO C C *** EXTERNAL FUNCTIONS *** C EXTERNAL D7TPR REAL D7TPR C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTYPE, HC, JTOL, NITER, RMAT, S PARAMETER (DFAC=41, DTYPE=16, HC=71, JTOL=59, NITER=31, RMAT=78, 1 S=62) C PARAMETER (ZERO=0.E+0) C C *** BODY *** C IF (IV(DTYPE) .NE. 1 .AND. IV(NITER) .GT. 0) GO TO 999 R1I = IV(RMAT) HII = IV(HC) - 1 VDFAC = V(DFAC) JTOL0 = IV(JTOL) - 1 D0 = JTOL0 + P S1 = IV(S) - 1 DO 30 I = 1, P IF (R1I .LE. 0) GO TO 10 T = D7TPR(I, V(R1I), V(R1I)) R1I = R1I + I GO TO 20 10 HII = HII + I T = ABS(V(HII)) 20 S1 = S1 + I IF (I .LE. PS) T = T + MAX(V(S1), ZERO) T = SQRT(T) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = MAX(V(D0), V(JTOLI)) D(I) = MAX(VDFAC*D(I), T) 30 CONTINUE C 999 RETURN C *** LAST LINE OF D7UP5 FOLLOWS *** END SUBROUTINE G7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W) C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN *** C C *** PARAMETER DECLARATIONS *** C INTEGER KA, P REAL D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C ( G7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT C CALL THIS ROUTINE. C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C D7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C L7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C L7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C L7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C L7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C R7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS. C V2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB. C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL RESTRT INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X REAL ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK, 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ, 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI C C *** CONSTANTS *** REAL BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, 1 ONE, P001, SIX, THREE, TWO, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, L7SVN, R7MDC, V2NRM EXTERNAL D7TPR, L7ITV, L7IVM, L7SRT, L7SVN, R7MDC, V2NRM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC, 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0 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.0E+0, FOUR=4.0E+0, HALF=0.5E+0, 1 KAPPA=2.0E+0, NEGONE=-1.0E+0, ONE=1.0E+0, P001=1.0E-3, 2 SIX=6.0E+0, THREE=3.0E+0, TWO=2.0E+0, ZERO=0.0E+0) SAVE DGXFAC DATA BIG/0.E+0/, DGXFAC/0.E+0/ C C *** BODY *** C IF (BIG .LE. ZERO) BIG = R7MDC(6) C C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX). DGGDMX = P + 1 C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX) C *** AND W(EMIN) RESPECTIVELY. EMAX = DGGDMX + 1 EMIN = EMAX + 1 C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST, C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF. C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN) C *** RESPECTIVELY. LK0 = EMIN + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P). DIAG0 = DSTSAV DIAG = DIAG0 + 1 C *** STORE -D*STEP IN W(Q),...,W(Q0+P). Q0 = DIAG0 + P Q = Q0 + 1 C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X *** X = Q + P RAD = V(RADIUS) RADSQ = RAD**2 C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF C *** D*STEP. PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD PSIFAC = BIG T1 = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) * 1 (KAPPA + ONE) + KAPPA + TWO) * RAD) IF (T1 .LT. BIG* MIN(RAD,ONE)) PSIFAC = T1 / RAD C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO EPS = V(EPSLON) IRC = 0 RESTRT = .FALSE. KALIM = KA + 50 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA .GE. 0) GO TO 290 C C *** FRESH START *** C K = 0 UK = NEGONE KA = 0 KALIM = 50 V(DGNORM) = V2NRM(P, DIG) V(NREDUC) = ZERO V(DST0) = ZERO KAMIN = 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 C C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) *** C J = 0 DO 10 I = 1, P J = J + I K1 = DIAG0 + I W(K1) = DIHDI(J) 10 CONTINUE C C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI *** C T1 = ZERO J = P * (P + 1) / 2 DO 20 I = 1, J T = ABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 20 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 30 CALL L7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 50 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 40 I = 1, IRC 40 W(I) = ZERO W(IRC) = ONE CALL L7ITV(IRC, W, L, W) T1 = V2NRM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 50 LK = ZERO T = L7SVN(P, L, W(Q), W(Q)) IF (T .GE. ONE) GO TO 60 IF (V(DGNORM) .GE. T*T*BIG) GO TO 70 60 CALL L7IVM(P, W(Q), L, DIG) GTSTA = D7TPR(P, W(Q), W(Q)) V(NREDUC) = HALF * GTSTA CALL L7ITV(P, W(Q), L, W(Q)) DST = V2NRM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 260 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = ABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = MAX(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = MIN(UK, MAX(ALPHAK, LK)) C IF (IRC .NE. 0) GO TO 210 C C *** COMPUTE L0 FOR POSITIVE DEFINITE H *** C CALL L7IVM(P, W, L, W(Q)) T = V2NRM(P, W) W(PHIPIN) = RAD / T / T LK = MAX(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 * MAX(P001, SQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK IF (ALPHAK .LE. ZERO) ALPHAK = UK K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL L7SRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 240 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL L7ITV(IRC, W, L, W) T1 = V2NRM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK IF (UK .LT. LK) UK = LK IF (ALPHAK .LT. LK) GO TO 210 C C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK... C T = P001 * ALPHAK IF (T .LE. ZERO) T = P001 LK = ALPHAK + T IF (UK .LE. LK) UK = LK + T GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 240 CALL L7IVM(P, W(Q), L, DIG) GTSTA = D7TPR(P, W(Q), W(Q)) CALL L7ITV(P, W(Q), L, W(Q)) DST = V2NRM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270 IF (PHI .EQ. OLDPHI) GO TO 270 OLDPHI = PHI IF (PHI .LT. ZERO) GO TO 330 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 250 IF (KA .GE. KALIM) GO TO 270 C *** THE FOLLOWING MIN IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK) C *** KAMIN = 0 ONLY IFF THE GRADIENT VANISHES *** IF (KAMIN .EQ. 0) GO TO 210 CALL L7IVM(P, W, L, W(Q)) C *** THE FOLLOWING, COMMENTED CALCULATION OF ALPHAK IS SOMETIMES C *** SAFER BUT WORSE IN PERFORMANCE... C T1 = DST / V2NRM(P, W) C ALPHAK = ALPHAK + T1 * (PHI/RAD) * T1 T1 = V2NRM(P, W) ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD) LK = MAX(LK, ALPHAK) ALPHAK = LK GO TO 210 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 260 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 270 DO 280 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 280 CONTINUE V(GTSTEP) = -GTSTA V(PREDUC) = HALF * ( ABS(ALPHAK)*DST*DST + GTSTA) GO TO 410 C C C *** RESTART WITH NEW RADIUS *** C 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 300 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 300 CONTINUE UK = NEGONE GO TO 30 C 310 KAMIN = KA + 3 IF (V(DGNORM) .EQ. ZERO) KAMIN = 0 IF (KA .EQ. 0) GO TO 50 C DST = W(DSTSAV) ALPHAK = ABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD UK = T - W(EMIN) IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK IF (UK .LE. ZERO) UK = P001 IF (RAD .GT. V(RAD0)) GO TO 320 C C *** SMALLER RADIUS *** LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = MAX(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 250 C C *** BIGGER RADIUS *** 320 IF (ALPHAK .GT. ZERO) UK = MIN(UK, W(UK0)) LK = MAX(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = MAX(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 + MIN(ZERO, V(DST0)) TWOPSI = ALPHAK*DST*DST + GTSTA IF (KA .GE. KAMIN) GO TO 340 C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS C *** IT). IF (PSIFAC .GE. BIG) GO TO 340 IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370 C C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. USE ONE STEP OF INVERSE POWER METHOD WITH START C *** FROM L7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). L7SVN RETURNS C *** X AND W WITH L*W = X. C 340 T = L7SVN(P, L, W(X), W) C C *** NORMALIZE W *** DO 350 I = 1, P 350 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL L7ITV(P, W, L, W) T2 = ONE/ V2NRM(P, W) DO 360 I = 1, P 360 W(I) = T2*W(I) T = T2 * T C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = D7TPR(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = SQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C C *** THE ACTUAL TEST FOR THE SPECIAL CASE... C IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380 C C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE) C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE... C IF (V(DST0) .LE. ZERO) V(DST0) = MIN(V(DST0), T2**2 - ALPHAK) LK = MAX(LK, -V(DST0)) C C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT. C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * R7MDC(3) C IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250 GO TO 270 C C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE C 380 ALPHAK = -ALPHAK V(PREDUC) = HALF * TWOPSI C C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. C T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T* D7TPR(P,W(X),W))) IF (T .LT. EPS*TWOPSI/SIX) GO TO 390 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 390 DO 400 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 400 CONTINUE V(GTSTEP) = D7TPR(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 410 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 420 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 420 CONTINUE C 999 RETURN C C *** LAST LINE OF G7QTS FOLLOWS *** END SUBROUTINE ITSUM(D, G, IV, LIV, LV, P, V, X) C C *** PRINT ITERATION SUMMARY FOR ***SOL (VERSION 2.3) *** C C *** PARAMETER DECLARATIONS *** C INTEGER LIV, LV, P INTEGER IV(LIV) REAL D(P), G(P), V(LV), X(P) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER ALG, I, IV1, M, NF, NG, OL, PU CHARACTER*4 MODEL1(6), MODEL2(6) REAL NRELDF, OLDF, PRELDF, RELDF, ZERO C C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER ALGSAV, DSTNRM, F, FDIF, F0, NEEDHD, NFCALL, NFCOV, NGCOV, 1 NGCALL, NITER, NREDUC, OUTLEV, PREDUC, PRNTIT, PRUNIT, 2 RELDX, SOLPRT, STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C PARAMETER (ALGSAV=51, NEEDHD=36, NFCALL=6, NFCOV=52, NGCALL=30, 1 NGCOV=53, NITER=31, OUTLEV=19, PRNTIT=39, PRUNIT=21, 2 SOLPRT=22, STATPR=23, SUSED=64, X0PRT=24) C C *** V SUBSCRIPT VALUES *** C PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, PREDUC=7, 1 RELDX=17, STPPAR=5) C PARAMETER (ZERO=0.E+0) DATA MODEL1/' ',' ',' ',' ',' G ',' S '/, 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/ C C------------------------------- BODY -------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IV1 = IV(1) IF (IV1 .GT. 62) IV1 = IV1 - 51 OL = IV(OUTLEV) ALG = MOD(IV(ALGSAV)-1,2) + 1 IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 370 IF (IV1 .GE. 12) GO TO 120 IF (IV1 .EQ. 2 .AND. IV(NITER) .EQ. 0) GO TO 390 IF (OL .EQ. 0) GO TO 120 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 120 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999 10 NF = IV(NFCALL) - IABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = MAX( ABS(V(F0)), ABS(V(F))) IF (OLDF .LE. ZERO) GO TO 20 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 20 IF (OL .GT. 0) GO TO 60 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,30) 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,40) 40 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR) IV(NEEDHD) = 0 IF (ALG .EQ. 2) GO TO 50 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR) GO TO 120 C 50 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 V(STPPAR) GO TO 120 C C *** PRINT LONG SUMMARY LINE *** C 60 IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,70) 70 FORMAT(/11H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR,2X,6HD*STEP,2X,7HNPRELDF) IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,80) 80 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX, 1 3X,6HSTPPAR,3X,6HD*STEP,3X,7HNPRELDF) IV(NEEDHD) = 0 NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF IF (ALG .EQ. 2) GO TO 90 M = IV(SUSED) WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR), V(DSTNRM), NRELDF GO TO 120 C 90 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, 1 V(RELDX), V(STPPAR), V(DSTNRM), NRELDF 100 FORMAT(I6,I5,E10.3,2E9.2,E8.1,A3,A4,2E8.1,E9.2) 110 FORMAT(I6,I5,E11.3,2E10.2,3E9.1,E10.2) C 120 IF (IV1 .LE. 2) GO TO 999 I = IV(STATPR) IF (I .EQ. (-1)) GO TO 460 IF (I + IV1 .LT. 0) GO TO 460 GO TO (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, 1 330, 350, 500), IV1 C 130 WRITE(PU,140) 140 FORMAT(/26H ***** X-CONVERGENCE *****) GO TO 430 C 150 WRITE(PU,160) 160 FORMAT(/42H ***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 170 WRITE(PU,180) 180 FORMAT(/49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 430 C 190 WRITE(PU,200) 200 FORMAT(/42H ***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 430 C 210 WRITE(PU,220) 220 FORMAT(/33H ***** SINGULAR CONVERGENCE *****) GO TO 430 C 230 WRITE(PU,240) 240 FORMAT(/30H ***** FALSE CONVERGENCE *****) GO TO 430 C 250 WRITE(PU,260) 260 FORMAT(/38H ***** FUNCTION EVALUATION LIMIT *****) GO TO 430 C 270 WRITE(PU,280) 280 FORMAT(/28H ***** ITERATION LIMIT *****) GO TO 430 C 290 WRITE(PU,300) 300 FORMAT(/18H ***** STOPX *****) GO TO 430 C 310 WRITE(PU,320) 320 FORMAT(/44H ***** INITIAL F(X) CANNOT BE COMPUTED *****) C GO TO 390 C 330 WRITE(PU,340) 340 FORMAT(/37H ***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 350 WRITE(PU,360) 360 FORMAT(/43H ***** GRADIENT COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 460 GO TO 390 C 370 WRITE(PU,380) IV(1) 380 FORMAT(/14H ***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON ITSUM *** C 390 IF (IV(X0PRT) .NE. 0) WRITE(PU,400) (I, X(I), D(I), I = 1, P) 400 FORMAT(/23H I INITIAL X(I),8X,4HD(I)//(1X,I5,E17.6,E14.3)) C *** THE FOLLOWING ARE TO AVOID UNDEFINED VARIABLES WHEN THE C *** FUNCTION EVALUATION LIMIT IS 1... V(DSTNRM) = ZERO V(FDIF) = ZERO V(NREDUC) = ZERO V(PREDUC) = ZERO V(RELDX) = ZERO IF (IV1 .GE. 12) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0 .AND. ALG .EQ. 1) WRITE(PU,30) IF (OL .LT. 0 .AND. ALG .EQ. 2) WRITE(PU,40) IF (OL .GT. 0 .AND. ALG .EQ. 1) WRITE(PU,70) IF (OL .GT. 0 .AND. ALG .EQ. 2) WRITE(PU,80) IF (ALG .EQ. 1) WRITE(PU,410) IV(NFCALL), V(F) IF (ALG .EQ. 2) WRITE(PU,420) IV(NFCALL), V(F) 410 FORMAT(/6H 0,I5,E10.3) 420 FORMAT(/6H 0,I5,E11.3) GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 430 IV(NEEDHD) = 1 IF (IV(STATPR) .LE. 0) GO TO 460 OLDF = MAX( ABS(V(F0)), ABS(V(F))) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 440 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 440 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(PU,450) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 450 FORMAT(/9H FUNCTION,E17.6,8H RELDX,E17.3/12H FUNC. EVALS, 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,E16.3,6X,7HNPRELDF,E15.3) C 460 IF (IV(SOLPRT) .EQ. 0) GO TO 999 IV(NEEDHD) = 1 IF (IV(ALGSAV) .GT. 2) GO TO 999 WRITE(PU,470) 470 FORMAT(/22H I FINAL X(I),8X,4HD(I),10X,4HG(I)/) DO 480 I = 1, P 480 WRITE(PU,490) I, X(I), D(I), G(I) 490 FORMAT(1X,I5,E16.6,2E14.3) GO TO 999 C 500 WRITE(PU,510) 510 FORMAT(/24H INCONSISTENT DIMENSIONS) 999 RETURN C *** LAST LINE OF ITSUM FOLLOWS *** END SUBROUTINE IVSET(ALG, IV, LIV, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER LIV, LV INTEGER ALG, IV(LIV) REAL V(LV) C INTEGER I7MDCN EXTERNAL I7MDCN, V7DFL C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS. C V7DFL.... PROVIDES DEFAULT VALUES TO V. C INTEGER ALG1, MIV, MV INTEGER MINIV(4), MINV(4) C C *** SUBSCRIPTS FOR IV *** C INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH, 1 INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL, 2 MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT, 3 PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR, 4 VNEED, VSAVE, X0PRT C C *** IV SUBSCRIPT VALUES *** C PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16, 1 HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76, 2 IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17, 3 MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9, 4 OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21, 5 QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23, 6 VNEED=4, VSAVE=60, X0PRT=24) DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/, 1 MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/ C C------------------------------- BODY -------------------------------- C IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1) IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40 MIV = MINIV(ALG) IF (LIV .LT. MIV) GO TO 20 MV = MINV(ALG) IF (LV .LT. MV) GO TO 30 ALG1 = MOD(ALG-1,2) + 1 CALL V7DFL(ALG1, LV, V) IV(1) = 12 IF (ALG .GT. 2) IV(DRADPR) = 1 IV(IVNEED) = 0 IV(LASTIV) = MIV IV(LASTV) = MV IV(LMAT) = MV + 1 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PERM) = MIV + 1 IV(SOLPRT) = 1 IV(STATPR) = 1 IV(VNEED) = 0 IV(X0PRT) = 1 C IF (ALG1 .GE. 2) GO TO 10 C C *** REGRESSION VALUES C IV(COVPRT) = 3 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(HC) = 0 IV(IERR) = 0 IV(INITS) = 0 IV(IPIVOT) = 0 IV(NVDFLT) = 32 IV(VSAVE) = 58 IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3 IV(PARSAV) = IV(VSAVE) + NVSAVE IV(QRTYP) = 1 IV(RDREQ) = 3 IV(RMAT) = 0 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 IV(DTYPE) = 0 IV(INITH) = 1 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(NVDFLT) = 25 IV(PARSAV) = 47 IF (ALG .GT. 2) IV(PARSAV) = 61 GO TO 999 C 20 IV(1) = 15 GO TO 999 C 30 IV(1) = 16 GO TO 999 C 40 IV(1) = 67 C 999 RETURN C *** LAST LINE OF IVSET FOLLOWS *** END SUBROUTINE L7ITV(N, X, L, Y) C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 REAL XI, ZERO PARAMETER (ZERO=0.E+0) C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST LINE OF L7ITV FOLLOWS *** END SUBROUTINE L7IVM(N, X, L, Y) C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) REAL D7TPR EXTERNAL D7TPR INTEGER I, J, K REAL T, ZERO PARAMETER (ZERO=0.E+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 = D7TPR(I-1, L(J+1), X) J = J + I X(I) = (Y(I) - T)/L(J) 30 CONTINUE 999 RETURN C *** LAST LINE OF L7IVM FOLLOWS *** END SUBROUTINE L7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, KA, P INTEGER IPIVOT(P) REAL D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR Q7RGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR Q7RGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C L7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C D7TPR - RETURNS INNER PRODUCT OF TWO VECTORS. C L7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C L7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C V7CPY - COPIES ONE VECTOR TO ANOTHER. C V2NRM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 REAL A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** REAL DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, 1 TTOL, ZERO REAL BIG C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, L7SVN, R7MDC, V2NRM EXTERNAL D7TPR, L7ITV, L7IVM, L7SVN, R7MDC, V7CPY, V2NRM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR 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.E+0, EIGHT=8.E+0, HALF=0.5E+0, NEGONE=-1.E+0, 1 ONE=1.E+0, P001=1.E-3, THREE=3.E+0, TTOL=2.5E+0, 2 ZERO=0.E+0) SAVE BIG DATA BIG/0.E+0/ C C *** BODY *** C C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK, C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J) C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0), C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY. LK0 = P + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 RMAT0 = DSTSAV C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER C *** WORK ON THESE COPIES. RMAT = RMAT0 + 1 PP1O2 = P * (P + 1) / 2 RES0 = PP1O2 + RMAT0 RES = RES0 + 1 RAD = V(RADIUS) IF (RAD .GT. ZERO) 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2) IF (BIG .LE. ZERO) BIG = R7MDC(6) PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION. DTOL = ONE/DFAC DFACSQ = DFAC*DFAC C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO LK = ZERO UK = ZERO KALIM = KA + 12 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 V(NREDUC) = HALF* D7TPR(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 T = L7SVN(P, R, STEP, W(RES)) IF (T .GE. ONE) GO TO 30 IF ( V2NRM(P, QTR) .GE. BIG*T) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING L7ITV AND L7IVM. 30 CALL L7ITV(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = V2NRM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL L7IVM(P, STEP, R, STEP) T = ONE / V2NRM(P, STEP) W(PHIPIN) = (T/RAD)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = V2NRM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. C ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD ALPHAK = MIN(UK, MAX(ALPHAK, LK)) C C C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES *** C 110 KA = KA + 1 CALL V7CPY(PP1O2, W(RMAT), R) CALL V7CPY(P, W(RES), QTR) C C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. *** C IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * MAX(P001, SQRT(LK/UK)) IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK SQRTAK = SQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. ABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P L = I1*(I1+1)/2 + RMAT0 WL = W(L) SI = STEP(I1-1) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF ( ABS(SI) .GT. ABS(WL)) GO TO 220 IF (SI .EQ. ZERO) GO TO 260 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL L7ITV(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = V2NRM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - D7TPR(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL L7IVM(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / SQRT(W(I)) T = ONE / V2NRM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = MAX(LK, ALPHAK) ALPHAK = LK GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = ABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = MAX(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 = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = MIN( D7TPR(P,STEP,G), ZERO) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C 999 RETURN C C *** LAST LINE OF L7MST FOLLOWS *** END SUBROUTINE L7SQR(N, A, L) C C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE C *** SAME STORAGE. C C *** PARAMETERS *** C INTEGER N REAL A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1 REAL T C NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II IP1 = I + 1 I0 = I0 - I J0 = I*(I+1)/2 DO 20 JJ = 1, I J = IP1 - JJ J0 = J0 - J T = 0.0E0 DO 10 K = 1, J IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE IJ = I0 + J A(IJ) = T 20 CONTINUE 30 CONTINUE 999 RETURN END SUBROUTINE L7SRT(N1, N, L, A, IRC) C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C *** PARAMETERS *** C INTEGER N1, N, IRC REAL L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K REAL T, TD, ZERO C PARAMETER (ZERO=0.E+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) = SQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST LINE OF L7SRT *** END REAL FUNCTION L7SVN(P, L, X, Y) C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF L7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF L7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF L7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF L7SVN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO L7SVN RETURNS). C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C L7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1 REAL B, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C REAL HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL D7TPR, V2NRM, V2AXY C PARAMETER (HALF=0.5E+0, ONE=1.E+0, R9973=9973.E+0, ZERO=0.E+0) C C *** BODY *** C IX = 2 PM1 = P - 1 C C *** FIRST CHECK WHETHER TO RETURN L7SVN = 0 AND INITIALIZE X *** C II = 0 J0 = P*PM1/2 JJ = J0 + P IF (L(JJ) .EQ. ZERO) GO TO 110 IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = B / L(JJ) X(P) = XPLUS IF (P .LE. 1) GO TO 60 DO 10 I = 1, PM1 II = II + I IF (L(II) .EQ. ZERO) GO TO 110 JI = J0 + I X(I) = XPLUS * L(JI) 10 CONTINUE C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 50 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = ABS(XPLUS) SMINUS = ABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .GT. 0) CALL V2AXY(JM1, X, XPLUS, L(J0+1), X) 50 CONTINUE C C *** NORMALIZE X *** C 60 T = ONE/ V2NRM(P, X) DO 70 I = 1, P 70 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN L7SVN = 1/TWONORM(Y) *** C DO 100 J = 1, P JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J T = ZERO IF (JM1 .GT. 0) T = D7TPR(JM1, L(J0+1), Y) Y(J) = (X(J) - T) / L(JJ) 100 CONTINUE C L7SVN = ONE/ V2NRM(P, Y) GO TO 999 C 110 L7SVN = ZERO 999 RETURN C *** LAST LINE OF L7SVN FOLLOWS *** END REAL FUNCTION L7SVX(P, L, X, Y) C C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF L7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS C APPROXIMATION MAY BE CRUDE. C Y (OUT) IF L7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND- C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X C OVER-WRITES Y. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1 REAL B, BLJI, SMINUS, SPLUS, T, YI C C *** CONSTANTS *** C REAL HALF, ONE, R9973, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL D7TPR, V2NRM, V2AXY C PARAMETER (HALF=0.5E+0, ONE=1.E+0, R9973=9973.E+0, ZERO=0.E+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 + FLOAT(IX)/R9973) X(P) = B * L(JJ) IF (P .LE. 1) GO TO 40 DO 10 I = 1, PM1 JI = J0 + I X(I) = B * L(JI) 10 CONTINUE C C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P-1 TO 1 BY -1... DO 30 JJJ = 1, PM1 J = P - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) JM1 = J - 1 J0 = J*JM1/2 SPLUS = ZERO SMINUS = ZERO DO 20 I = 1, J JI = J0 + I BLJI = B * L(JI) SPLUS = SPLUS + ABS(BLJI + X(I)) SMINUS = SMINUS + ABS(BLJI - X(I)) 20 CONTINUE IF (SMINUS .GT. SPLUS) B = -B X(J) = ZERO C *** UPDATE PARTIAL SUMS *** CALL V2AXY(J, X, B, L(J0+1), X) 30 CONTINUE C C *** NORMALIZE X *** C 40 T = V2NRM(P, X) IF (T .LE. ZERO) GO TO 80 T = ONE / T DO 50 I = 1, P 50 X(I) = T*X(I) C C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) *** C DO 60 JJJ = 1, P J = PPLUS1 - JJJ JI = J*(J-1)/2 + 1 Y(J) = D7TPR(J, L(JI), X) 60 CONTINUE C C *** NORMALIZE Y AND SET X = (L**T)*Y *** C T = ONE / V2NRM(P, Y) JI = 1 DO 70 I = 1, P YI = T * Y(I) X(I) = ZERO CALL V2AXY(I, X, YI, L(JI), X) JI = JI + I 70 CONTINUE L7SVX = V2NRM(P, X) GO TO 999 C 80 L7SVX = ZERO C 999 RETURN C *** LAST LINE OF L7SVX FOLLOWS *** END SUBROUTINE L7TVM(N, X, L, Y) C C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY C *** OCCUPY THE SAME STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, IJ, I0, J REAL YI, ZERO PARAMETER (ZERO=0.E+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 999 RETURN C *** LAST LINE OF L7TVM FOLLOWS *** END SUBROUTINE L7VML(N, X, L, Y) C C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) C DIMENSION L(N*(N+1)/2) INTEGER I, II, IJ, I0, J, NP1 REAL T, ZERO PARAMETER (ZERO=0.E+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 999 RETURN C *** LAST LINE OF L7VML FOLLOWS *** END SUBROUTINE O7PRD(L, LS, P, S, W, Y, Z) C C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E., C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I). C INTEGER L, LS, P REAL S(LS), W(L), Y(P,L), Z(P,L) C DIMENSION S(P*(P+1)/2) C INTEGER I, J, K, M REAL WK, YI, ZERO DATA ZERO/0.E+0/ C DO 30 K = 1, L WK = W(K) IF (WK .EQ. ZERO) GO TO 30 M = 1 DO 20 I = 1, P YI = WK * Y(I,K) DO 10 J = 1, I S(M) = S(M) + YI*Z(J,K) M = M + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE C 999 RETURN C *** LAST LINE OF O7PRD FOLLOWS *** END SUBROUTINE PARCK(ALG, D, IV, LIV, LV, N, V) C C *** CHECK ***SOL (VERSION 2.3) PARAMETERS, PRINT CHANGED VALUES *** C C *** ALG = 1 FOR REGRESSION, ALG = 2 FOR GENERAL UNCONSTRAINED OPT. C INTEGER ALG, LIV, LV, N INTEGER IV(LIV) REAL D(N), V(LV) C REAL R7MDC EXTERNAL IVSET, R7MDC, V7CPY, V7DFL C IVSET -- SUPPLIES DEFAULT VALUES TO BOTH IV AND V. C R7MDC -- RETURNS MACHINE-DEPENDENT CONSTANTS. C V7CPY -- COPIES ONE VECTOR TO ANOTHER. C V7DFL -- SUPPLIES DEFAULT PARAMETER VALUES TO V ALONE. C C *** LOCAL VARIABLES *** C INTEGER ALG1, I, II, IV1, J, K, L, M, MIV1, MIV2, NDFALT, PARSV1, 1 PU INTEGER IJMP, JLIM(4), MINIV(4), NDFLT(4) CHARACTER*1 VARNM(2), SH(2) CHARACTER*4 CNGD(3), DFLT(3), VN(2,34), WHICH(3) REAL BIG, MACHEP, TINY, VK, VM(34), VX(34), ZERO C C *** IV AND V SUBSCRIPTS *** C INTEGER ALGSAV, DINIT, DTYPE, DTYPE0, EPSLON, INITS, IVNEED, 1 LASTIV, LASTV, LMAT, NEXTIV, NEXTV, NVDFLT, OLDN, 2 PARPRT, PARSAV, PERM, PRUNIT, VNEED C C 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.E+0/, MACHEP/-1.E+0/, TINY/1.E+0/, ZERO/0.E+0/ DATA VN(1,1),VN(2,1)/'EPSL','ON..'/ DATA VN(1,2),VN(2,2)/'PHMN','FC..'/ DATA VN(1,3),VN(2,3)/'PHMX','FC..'/ DATA VN(1,4),VN(2,4)/'DECF','AC..'/ DATA VN(1,5),VN(2,5)/'INCF','AC..'/ DATA VN(1,6),VN(2,6)/'RDFC','MN..'/ DATA VN(1,7),VN(2,7)/'RDFC','MX..'/ DATA VN(1,8),VN(2,8)/'TUNE','R1..'/ DATA VN(1,9),VN(2,9)/'TUNE','R2..'/ DATA VN(1,10),VN(2,10)/'TUNE','R3..'/ DATA VN(1,11),VN(2,11)/'TUNE','R4..'/ DATA VN(1,12),VN(2,12)/'TUNE','R5..'/ DATA VN(1,13),VN(2,13)/'AFCT','OL..'/ DATA VN(1,14),VN(2,14)/'RFCT','OL..'/ DATA VN(1,15),VN(2,15)/'XCTO','L...'/ DATA VN(1,16),VN(2,16)/'XFTO','L...'/ DATA VN(1,17),VN(2,17)/'LMAX','0...'/ DATA VN(1,18),VN(2,18)/'LMAX','S...'/ DATA VN(1,19),VN(2,19)/'SCTO','L...'/ DATA VN(1,20),VN(2,20)/'DINI','T...'/ DATA VN(1,21),VN(2,21)/'DTIN','IT..'/ DATA VN(1,22),VN(2,22)/'D0IN','IT..'/ DATA VN(1,23),VN(2,23)/'DFAC','....'/ DATA VN(1,24),VN(2,24)/'DLTF','DC..'/ DATA VN(1,25),VN(2,25)/'DLTF','DJ..'/ DATA VN(1,26),VN(2,26)/'DELT','A0..'/ DATA VN(1,27),VN(2,27)/'FUZZ','....'/ DATA VN(1,28),VN(2,28)/'RLIM','IT..'/ DATA VN(1,29),VN(2,29)/'COSM','IN..'/ DATA VN(1,30),VN(2,30)/'HUBE','RC..'/ DATA VN(1,31),VN(2,31)/'RSPT','OL..'/ DATA VN(1,32),VN(2,32)/'SIGM','IN..'/ DATA VN(1,33),VN(2,33)/'ETA0','....'/ DATA VN(1,34),VN(2,34)/'BIAS','....'/ C DATA VM(1)/1.0E-3/, VM(2)/-0.99E+0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/, 1 VM(5)/1.2E+0/, VM(6)/1.E-2/, VM(7)/1.2E+0/, VM(8)/0.E+0/, 2 VM(9)/0.E+0/, VM(10)/1.E-3/, VM(11)/-1.E+0/, VM(13)/0.E+0/, 3 VM(15)/0.E+0/, VM(16)/0.E+0/, VM(19)/0.E+0/, VM(20)/-10.E+0/, 4 VM(21)/0.E+0/, VM(22)/0.E+0/, VM(23)/0.E+0/, VM(27)/1.01E+0/, 5 VM(28)/1.E+10/, VM(30)/0.E+0/, VM(31)/0.E+0/, VM(32)/0.E+0/, 6 VM(34)/0.E+0/ DATA VX(1)/0.9E+0/, VX(2)/-1.E-3/, VX(3)/1.E+1/, VX(4)/0.8E+0/, 1 VX(5)/1.E+2/, VX(6)/0.8E+0/, VX(7)/1.E+2/, VX(8)/0.5E+0/, 2 VX(9)/0.5E+0/, VX(10)/1.E+0/, VX(11)/1.E+0/, VX(14)/0.1E+0/, 3 VX(15)/1.E+0/, VX(16)/1.E+0/, VX(19)/1.E+0/, VX(23)/1.E+0/, 4 VX(24)/1.E+0/, VX(25)/1.E+0/, VX(26)/1.E+0/, VX(27)/1.E+10/, 5 VX(29)/1.E+0/, VX(31)/1.E+0/, VX(32)/1.E+0/, VX(33)/1.E+0/, 6 VX(34)/1.E+0/ C DATA VARNM(1)/'P'/, VARNM(2)/'P'/, SH(1)/'S'/, SH(2)/'H'/ DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/, 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/ C C............................... BODY ................................ C PU = 0 IF (PRUNIT .LE. LIV) PU = IV(PRUNIT) IF (ALGSAV .GT. LIV) GO TO 20 IF (ALG .EQ. IV(ALGSAV)) GO TO 20 IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV) 10 FORMAT(/40H THE FIRST PARAMETER TO IVSET SHOULD BE,I3, 1 12H RATHER THAN,I3) IV(1) = 67 GO TO 999 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340 MIV1 = MINIV(ALG) IF (IV(1) .EQ. 15) GO TO 360 ALG1 = MOD(ALG-1,2) + 1 IF (IV(1) .EQ. 0) CALL IVSET(ALG, IV, LIV, LV, V) IV1 = IV(1) IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30 IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1) IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2 IF (LIV .LT. MIV1) GO TO 300 IV(IVNEED) = 0 IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1 IV(VNEED) = 0 IF (LIV .LT. MIV2) GO TO 300 IF (LV .LT. IV(LASTV)) GO TO 320 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60 IF (N .GE. 1) GO TO 50 IV(1) = 81 IF (PU .EQ. 0) GO TO 999 WRITE(PU,40) VARNM(ALG1), N 40 FORMAT(/8H /// BAD,A1,2H =,I5) GO TO 999 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM) IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT) IF (IV1 .EQ. 13) GO TO 999 K = IV(PARSAV) - EPSLON CALL V7DFL(ALG1, LV-K, V(K+1)) IV(DTYPE0) = 2 - ALG1 IV(OLDN) = N WHICH(1) = DFLT(1) WHICH(2) = DFLT(2) WHICH(3) = DFLT(3) GO TO 110 60 IF (N .EQ. IV(OLDN)) GO TO 80 IV(1) = 17 IF (PU .EQ. 0) GO TO 999 WRITE(PU,70) VARNM(ALG1), IV(OLDN), N 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5) GO TO 999 C 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100 IV(1) = 80 IF (PU .NE. 0) WRITE(PU,90) IV1 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.) GO TO 999 C 100 WHICH(1) = CNGD(1) WHICH(2) = CNGD(2) WHICH(3) = CNGD(3) C 110 IF (IV1 .EQ. 14) IV1 = 12 IF (BIG .GT. TINY) GO TO 120 TINY = R7MDC(1) MACHEP = R7MDC(3) BIG = R7MDC(6) VM(12) = MACHEP VX(12) = BIG VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = TINY VX(18) = BIG VX(20) = BIG VX(21) = BIG VX(22) = BIG VM(24) = MACHEP VM(25) = MACHEP VM(26) = MACHEP VX(28) = R7MDC(5) VM(29) = MACHEP VX(30) = BIG VM(33) = MACHEP 120 M = 0 I = 1 J = JLIM(ALG1) K = EPSLON NDFALT = NDFLT(ALG1) DO 150 L = 1, NDFALT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140 M = K IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK, 1 VM(I), VX(I) 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,E11.3,7H SHOULD, 1 11H BE BETWEEN,E11.3,4H AND,E11.3) 140 K = K + 1 I = I + 1 IF (I .EQ. J) I = IJMP 150 CONTINUE C IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170 IV(1) = 51 IF (PU .EQ. 0) GO TO 999 WRITE(PU,160) IV(NVDFLT), NDFALT 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5) GO TO 999 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12) 1 GO TO 200 DO 190 I = 1, N IF (D(I) .GT. ZERO) GO TO 190 M = 18 IF (PU .NE. 0) WRITE(PU,180) I, D(I) 180 FORMAT(/8H /// D(,I3,3H) =,E11.3,19H SHOULD BE POSITIVE) 190 CONTINUE 200 IF (M .EQ. 0) GO TO 210 IV(1) = M GO TO 999 C 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230 M = 1 WRITE(PU,220) SH(ALG1), IV(INITS) 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =, 1 I3) 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250 IF (M .EQ. 0) WRITE(PU,260) WHICH M = 1 WRITE(PU,240) IV(DTYPE) 240 FORMAT(20H DTYPE..... IV(16) =,I3) 250 I = 1 J = JLIM(ALG1) K = EPSLON L = IV(PARSAV) NDFALT = NDFLT(ALG1) DO 290 II = 1, NDFALT IF (V(K) .EQ. V(L)) GO TO 280 IF (M .EQ. 0) WRITE(PU,260) WHICH 260 FORMAT(/1H ,3A4,9HALUES..../) M = 1 WRITE(PU,270) VN(1,I), VN(2,I), K, V(K) 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,E15.7) 280 K = K + 1 L = L + 1 I = I + 1 IF (I .EQ. J) I = IJMP 290 CONTINUE C IV(DTYPE0) = IV(DTYPE) PARSV1 = IV(PARSAV) CALL V7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON)) GO TO 999 C 300 IV(1) = 15 IF (PU .EQ. 0) GO TO 999 WRITE(PU,310) LIV, MIV2 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5) IF (LIV .LT. MIV1) GO TO 999 IF (LV .LT. IV(LASTV)) GO TO 320 GO TO 999 C 320 IV(1) = 16 IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV) 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5) GO TO 999 C 340 IV(1) = 67 IF (PU .NE. 0) WRITE(PU,350) ALG 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4) GO TO 999 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5, 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV) IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1 IF (LASTV .LE. LIV) IV(LASTV) = 0 C 999 RETURN C *** LAST LINE OF PARCK FOLLOWS *** END SUBROUTINE Q7ADR(P, QTR, RMAT, W, Y) C C *** ADD ROW W TO QR FACTORIZATION WITH R MATRIX RMAT AND C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENT OF RESIDUAL C *** CORRESPONDING TO W. C INTEGER P REAL QTR(P), RMAT(1), W(P), Y C DIMENSION RMAT(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IJ, IP1, J REAL RI, RW, T, U1, U2, V, WI, WR C REAL ONE, ZERO PARAMETER (ONE=1.E+0, ZERO=0.E+0) C C------------------------------ BODY ----------------------------------- C II = 0 DO 60 I = 1, P II = II+I WI = W(I) IF (WI .EQ. ZERO) GOTO 60 RI = RMAT(II) IF (RI .NE. ZERO) GOTO 20 IJ = II C *** SWAP W AND ROW I OF RMAT *** DO 10 J = I, P T = RMAT(IJ) RMAT(IJ) = W(J) W(J) = T IJ = IJ+J 10 CONTINUE T = QTR(I) QTR(I) = Y Y = T GO TO 60 20 IP1 = I+1 IJ = II+I IF ( ABS(WI) .LE. ABS(RI)) GO TO 40 RW = RI/WI T = SQRT(ONE+RW**2) IF (RW .GT. ZERO) T = -T V = RW-T U1 = ONE/T U2 = ONE/(T*V) RMAT(II) = WI*T T = Y+V*QTR(I) QTR(I) = QTR(I)+T*U1 Y = Y+T*U2 IF (IP1 .GT. P) GO TO 60 DO 30 J = IP1, P T = W(J)+V*RMAT(IJ) RMAT(IJ) = RMAT(IJ)+T*U1 W(J) = W(J)+T*U2 IJ = IJ+J 30 CONTINUE GO TO 60 C C *** AT THIS POINT WE MUST HAVE ABS(WI) .LE. ABS(RI)... C 40 WR = WI/RI T = - SQRT(ONE+WR**2) V = WR/(ONE-T) U1 = ONE/T-ONE U2 = V*U1 RMAT(II) = RI*T T = QTR(I)+V*Y QTR(I) = QTR(I)+T*U1 Y = Y+T*U2 IF (IP1 .GT. P) GO TO 60 DO 50 J = IP1, P T = RMAT(IJ)+V*W(J) RMAT(IJ) = RMAT(IJ)+T*U1 W(J) = W(J)+T*U2 IJ = IJ+J 50 CONTINUE 60 CONTINUE 999 RETURN END REAL FUNCTION RLDST(P, D, X, X0) C C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 *** C *** NL2SOL VERSION 2.2 *** C INTEGER P REAL D(P), X(P), X0(P) C INTEGER I REAL EMAX, T, XMAX, ZERO PARAMETER (ZERO=0.E+0) C C *** BODY *** C EMAX = ZERO XMAX = ZERO DO 10 I = 1, P T = ABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * ( ABS(X(I)) + ABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE RLDST = ZERO IF (XMAX .GT. ZERO) RLDST = EMAX / XMAX 999 RETURN C *** LAST LINE OF RLDST FOLLOWS *** END SUBROUTINE S7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, 1 Y) C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL A(1), COSMIN, SIZE, STEP(P), U(P), W(P), 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, J, K REAL DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** REAL HALF, ONE, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C REAL D7TPR, V2NRM EXTERNAL D7TPR, S7LVM, V2NRM C PARAMETER (HALF=0.5E+0, ONE=1.E+0, ZERO=0.E+0) C C----------------------------------------------------------------------- C SDOTWM = D7TPR(P, STEP, WCHMTD) DENMIN = COSMIN * V2NRM(P,STEP) * V2NRM(P,WCHMTD) WSCALE = ONE IF (DENMIN .NE. ZERO) WSCALE = MIN(ONE, ABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL S7LVM(P, U, A, STEP) T = HALF * (SIZE * D7TPR(P, STEP, U) - D7TPR(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST LINE OF S7LUP FOLLOWS *** END SUBROUTINE S7LVM(P, Y, S, X) C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, J, K REAL XI C C C *** EXTERNAL FUNCTION *** C REAL D7TPR EXTERNAL D7TPR C C----------------------------------------------------------------------- C J = 1 DO 10 I = 1, P Y(I) = D7TPR(I, S(J), X) J = J + I 10 CONTINUE C IF (P .LE. 1) GO TO 999 J = 1 DO 40 I = 2, P XI = X(I) IM1 = I - 1 J = J + 1 DO 30 K = 1, IM1 Y(K) = Y(K) + S(J)*XI J = J + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST LINE OF S7LVM FOLLOWS *** END SUBROUTINE V2AXY(P, W, A, X, Y) C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C INTEGER P REAL A, W(P), X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END REAL FUNCTION V2NRM(P, X) C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C INTEGER P REAL X(P) C INTEGER I, J REAL ONE, R, SCALE, SQTETA, T, XI, ZERO REAL R7MDC EXTERNAL R7MDC C PARAMETER (ONE=1.E+0, ZERO=0.E+0) SAVE SQTETA DATA SQTETA/0.E+0/ C IF (P .GT. 0) GO TO 10 V2NRM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE V2NRM = ZERO GO TO 999 C 30 SCALE = ABS(X(I)) IF (I .LT. P) GO TO 40 V2NRM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = R7MDC(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = ABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C V2NRM = SCALE * SQRT(T) 999 RETURN C *** LAST LINE OF V2NRM FOLLOWS *** END SUBROUTINE V7CPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C INTEGER P REAL X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) RETURN END SUBROUTINE V7DFL(ALG, LV, V) C C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V *** C C *** ALG = 1 MEANS REGRESSION CONSTANTS. C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. C INTEGER ALG, LV REAL V(LV) C REAL R7MDC EXTERNAL R7MDC C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS C REAL MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR V *** C INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC, 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ, HUBERC, 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX, 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2, 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL C PARAMETER (ONE=1.E+0, THREE=3.E+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, HUBERC=48, 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21, 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49, 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28, 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34) C C------------------------------- BODY -------------------------------- C MACHEP = R7MDC(3) V(AFCTOL) = 1.E-20 IF (MACHEP .GT. 1.E-10) V(AFCTOL) = MACHEP**2 V(DECFAC) = 0.5E+0 SQTEPS = R7MDC(4) V(DFAC) = 0.6E+0 V(DTINIT) = 1.E-6 MEPCRT = MACHEP ** (ONE/THREE) V(D0INIT) = 1.E+0 V(EPSLON) = 0.1E+0 V(INCFAC) = 2.E+0 V(LMAX0) = 1.E+0 V(LMAXS) = 1.E+0 V(PHMNFC) = -0.1E+0 V(PHMXFC) = 0.1E+0 V(RDFCMN) = 0.1E+0 V(RDFCMX) = 4.E+0 V(RFCTOL) = MAX(1.E-10, MEPCRT**2) V(SCTOL) = V(RFCTOL) V(TUNER1) = 0.1E+0 V(TUNER2) = 1.E-4 V(TUNER3) = 0.75E+0 V(TUNER4) = 0.5E+0 V(TUNER5) = 0.75E+0 V(XCTOL) = SQTEPS V(XFTOL) = 1.E+2 * MACHEP C IF (ALG .GE. 2) GO TO 10 C C *** REGRESSION VALUES C V(COSMIN) = MAX(1.E-6, 1.E+2 * MACHEP) V(DINIT) = 0.E+0 V(DELTA0) = SQTEPS V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(FUZZ) = 1.5E+0 V(HUBERC) = 0.7E+0 V(RLIMIT) = R7MDC(5) V(RSPTOL) = 1.E-3 V(SIGMIN) = 1.E-4 GO TO 999 C C *** GENERAL OPTIMIZATION VALUES C 10 V(BIAS) = 0.8E+0 V(DINIT) = -1.0E+0 V(ETA0) = 1.0E+3 * MACHEP C 999 RETURN C *** LAST LINE OF V7DFL FOLLOWS *** END SUBROUTINE V7SCL(N, X, A, Y) C C *** SET X(I) = A*Y(I), I = 1(1)N *** C INTEGER N REAL A, X(N), Y(N) C INTEGER I C DO 10 I = 1, N 10 X(I) = A * Y(I) 999 RETURN C *** LAST LINE OF V7SCL FOLLOWS *** END SUBROUTINE V7SCP(P, Y, S) C C *** SET P-VECTOR Y TO SCALAR S *** C INTEGER P REAL S, Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = S RETURN END REAL FUNCTION VSUM(N, X) INTEGER N REAL X(N) INTEGER I C VSUM = 0.E+0 DO 10 I = 1, N 10 VSUM = VSUM + X(I) END LOGICAL FUNCTION STOPX(IDUMMY) C *****PARAMETERS... INTEGER IDUMMY C C .................................................................. C C *****PURPOSE... C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A C DYNAMIC STOPX. C C *****ALGORITHM NOTES... C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. C C .................................................................. C STOPX = .FALSE. RETURN END //GO.SYSIN DD sgletc.f cat >smadsen.f <<'//GO.SYSIN DD smadsen.f' C *** SIMPLE TEST PROGRAM FOR GLG AND GLF *** C INTEGER IV(92), LIV, LV, NOUT, UI(1) REAL V(200), X(2), UR(1) EXTERNAL I7MDCN, MADRJ, RHOLS INTEGER I7MDCN C C I7MDCN... RETURNS OUTPUT UNIT NUMBER. C INTEGER COVPRT, COVREQ, LASTIV, LASTV, LMAX0, RDREQ PARAMETER (COVPRT=14, COVREQ=15, LASTIV=44, LASTV=45, LMAX0=35, 1 RDREQ=57) C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NOUT = I7MDCN(1) LV = 200 LIV = 92 C C *** SPECIFY INITIAL X *** C X(1) = 3.E+0 X(2) = 1.E+0 C C *** SET IV(1) TO 0 TO FORCE ALL DEFAULT INPUT COMPONENTS TO BE USED. C IV(1) = 0 C WRITE(NOUT,10) 10 FORMAT(' GLG ON PROBLEM MADSEN...') C C *** CALL GLG, PASSING UI FOR RHOI, UR FOR RHOR, AND MADRJ FOR C *** UFPARM (ALL UNUSED IN THIS EXAMPLE). C CALL GLG(3, 2, 2, X, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, UI, 1 UR, MADRJ) C C *** SEE HOW MUCH STORAGE GLG USED... C WRITE(NOUT,20) IV(LASTIV), IV(LASTV) 20 FORMAT(' GLG NEEDED LIV .GE. ,I3,12H AND LV .GE.',I4) C C *** SOLVE THE SAME PROBLEM USING GLF... C WRITE(NOUT,30) 30 FORMAT(/' GLF ON PROBLEM MADSEN...') X(1) = 3.E+0 X(2) = 1.E+0 IV(1) = 0 CALL GLF(3, 2, 2, X, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, UI, 1 UR, MADRJ) C C *** REPEAT THE LAST RUN, BUT WITH A DIFFERENT INITIAL STEP BOUND C *** AND WITH THE COVARIANCE AND REGRESSION DIAGNOSTIC CALCUATIONS C *** SUPPRESSED... C C *** FIRST CALL IVSET TO GET DEFAULT IV AND V INPUT VALUES... C CALL IVSET(1, IV, LIV, LV, V) C C *** NOW ASSIGN THE NONDEFAULT VALUES. C IV(COVPRT) = 0 IV(COVREQ) = 0 IV(RDREQ) = 0 V(LMAX0) = 0.1E+0 X(1) = 3.E+0 X(2) = 1.E+0 C WRITE(NOUT,40) 40 FORMAT(/' GLF ON PROBLEM MADSEN AGAIN...') C CALL GLF(3, 2, 2, X, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, UI, 1 UR, MADRJ) C STOP END C*********************************************************************** C C MADRJ C C*********************************************************************** SUBROUTINE MADRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) INTEGER N, P, NF, NEED, UI(1) REAL X(P), R(N), RP(P,N), UR(1) EXTERNAL UF REAL TWO, ZERO PARAMETER (TWO = 2.E+0, ZERO = 0.E+0) C C *** BODY *** C IF (NEED .EQ. 2) GO TO 10 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) GO TO 999 C 10 RP(1,1) = TWO*X(1) + X(2) RP(2,1) = TWO*X(2) + X(1) RP(1,2) = COS(X(1)) RP(2,2) = ZERO RP(1,3) = ZERO RP(2,3) = -SIN(X(2)) C 999 RETURN END SUBROUTINE RHOLS(NEED, F, N, NF, XN, R, RP, UI, UR, W) C C *** LEAST-SQUARES RHO *** C INTEGER NEED(2), N, NF, UI(1) REAL F, XN(*), R(N), RP(N), UR(1), W(N) C C *** EXTERNAL FUNCTIONS *** C EXTERNAL R7MDC, V2NRM REAL R7MDC, V2NRM C C *** LOCAL VARIABLES *** C INTEGER I REAL HALF, ONE, RLIMIT, ZERO DATA HALF/0.5E+0/, ONE/1.E+0/, RLIMIT/0.E+0/, ZERO/0.E+0/ C C *** BODY *** C IF (NEED(1) .EQ. 2) GO TO 20 IF (RLIMIT .LE. ZERO) RLIMIT = R7MDC(5) C ** SET F TO 2-NORM OF R ** F = V2NRM(N, R) IF (F .GE. RLIMIT) GO TO 10 F = HALF * F**2 GO TO 999 C C ** COME HERE IF F WOULD OVERFLOW... 10 NF = 0 GO TO 999 C 20 DO 30 I = 1, N RP(I) = ONE W(I) = ONE 30 CONTINUE 999 RETURN C *** LAST LINE OF RHOLS FOLLOWS *** END //GO.SYSIN DD smadsen.f cat >smadsenb.f <<'//GO.SYSIN DD smadsenb.f' C *** SIMPLE TEST PROGRAM FOR GLGB AND GLFB *** C INTEGER IV(92), LIV, LV, NOUT, UI(1) REAL B(2,2), V(200), X(2), UR(1) EXTERNAL I7MDCN, MADRJ, RHOLS INTEGER I7MDCN C C I7MDCN... RETURNS OUTPUT UNIT NUMBER. C INTEGER LASTIV, LASTV, LMAX0 PARAMETER (LASTIV=44, LASTV=45, LMAX0=35) C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NOUT = I7MDCN(1) LV = 200 LIV = 92 C C *** SPECIFY INITIAL X AND BOUNDS ON X *** C X(1) = 3.E+0 X(2) = 1.E+0 C *** BOUNDS ON X(1)... B(1,1) = -.1E+0 B(2,1) = 10.E+0 C *** BOUNDS ON X(2)... B(1,2) = 0.E+0 B(2,2) = 2.E+0 C C *** SET IV(1) TO 0 TO FORCE ALL DEFAULT INPUT COMPONENTS TO BE USED. C IV(1) = 0 C WRITE(NOUT,10) 10 FORMAT(' GLGB ON PROBLEM MADSEN...') C C *** CALL GLG, PASSING UI FOR RHOI, UR FOR RHOR, AND MADRJ FOR C *** UFPARM (ALL UNUSED IN THIS EXAMPLE). C CALL GLGB(3, 2, 2, X, B, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, 1 UI,UR, MADRJ) C C *** SEE HOW MUCH STORAGE GLGB USED... C WRITE(NOUT,20) IV(LASTIV), IV(LASTV) 20 FORMAT(' GLGB NEEDED LIV .GE. ,I3,12H AND LV .GE.',I4) C C *** SOLVE THE SAME PROBLEM USING GLFB... C WRITE(NOUT,30) 30 FORMAT(/' GLFB ON PROBLEM MADSEN...') X(1) = 3.E+0 X(2) = 1.E+0 IV(1) = 0 CALL GLFB(3, 2, 2, X, B, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, 1 UI,UR, MADRJ) C C *** REPEAT THE LAST RUN, BUT WITH A DIFFERENT INITIAL STEP BOUND C C *** FIRST CALL IVSET TO GET DEFAULT IV AND V INPUT VALUES... C CALL IVSET(1, IV, LIV, LV, V) C C *** NOW ASSIGN THE NONDEFAULT VALUES. C V(LMAX0) = 0.1E+0 X(1) = 3.E+0 X(2) = 1.E+0 C WRITE(NOUT,40) 40 FORMAT(/' GLFB ON PROBLEM MADSEN AGAIN...') C CALL GLFB(3, 2, 2, X, B, RHOLS, UI, UR, IV, LIV, LV, V, MADRJ, 1 UI,UR, MADRJ) C STOP END C*********************************************************************** C C MADRJ C C*********************************************************************** SUBROUTINE MADRJ(N, P, X, NF, NEED, R, RP, UI, UR, UF) INTEGER N, P, NF, NEED, UI(1) REAL X(P), R(N), RP(P,N), UR(1) EXTERNAL UF REAL TWO, ZERO PARAMETER (TWO=2.E+0, ZERO=0.E+0) C C *** BODY *** C IF (NEED .EQ. 2) GO TO 10 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) GO TO 999 C 10 RP(1,1) = TWO*X(1) + X(2) RP(2,1) = TWO*X(2) + X(1) RP(1,2) = COS(X(1)) RP(2,2) = ZERO RP(1,3) = ZERO RP(2,3) = -SIN(X(2)) C 999 RETURN END SUBROUTINE RHOLS(NEED, F, N, NF, XN, R, RP, UI, UR, W) C C *** LEAST-SQUARES RHO *** C INTEGER NEED(2), N, NF, UI(1) REAL F, XN(*), R(N), RP(N), UR(1), W(N) C C *** EXTERNAL FUNCTIONS *** C EXTERNAL R7MDC, V2NRM REAL R7MDC, V2NRM C C *** LOCAL VARIABLES *** C INTEGER I REAL HALF, ONE, RLIMIT, ZERO DATA HALF/0.5E+0/, ONE/1.E+0/, RLIMIT/0.E+0/, ZERO/0.E+0/ C C *** BODY *** C IF (NEED(1) .EQ. 2) GO TO 20 IF (RLIMIT .LE. ZERO) RLIMIT = R7MDC(5) C ** SET F TO 2-NORM OF R ** F = V2NRM(N, R) IF (F .GE. RLIMIT) GO TO 10 F = HALF * F**2 GO TO 999 C C ** COME HERE IF F WOULD OVERFLOW... 10 NF = 0 GO TO 999 C 20 DO 30 I = 1, N RP(I) = ONE W(I) = ONE 30 CONTINUE 999 RETURN C *** LAST LINE OF RHOLS FOLLOWS *** END //GO.SYSIN DD smadsenb.f cat >spmain.f <<'//GO.SYSIN DD spmain.f' PROGRAM PMAIN C *** MAIN PROGRAM FOR RUNNING PREG EXAMPLES USING GLG *** INTEGER LIV, LV, MMAX, NMAX, NW, NR0, PMAX PARAMETER (LIV=200, LV=8000, NW=6, MMAX = 18, NMAX=200, NR0=8, 1 PMAX=20) CHARACTER*72 FNAME CHARACTER*6 ALGNAM(4) INTEGER ALG, I, IV(LIV), J, J0, J1, K, KDIAG, M, MDL(6), MODEL, 1 N, NIN, NR, NRUN, P, P0, PS, RHOI(NMAX+6), UI(7) REAL A((MMAX+6)*NMAX), B(2,PMAX), 1 RHOR((17+PMAX)*NMAX+4), T, T1, V(LV), X(PMAX+3), 1 X0(PMAX+3), YN(2,7*NMAX+3) EQUIVALENCE (RHOI(1), MDL(1)), (RHOR(1), YN(1,1)) CHARACTER*96 DESC, FMT CHARACTER*8 WNAME(4) REAL R7MDC EXTERNAL BRJ, CHKDER, DEVIAN, GLF, GLFB, GLG, GLGB, IVSET, 1 R7MDC, V7CPY, V7SCP, LOUCHK, POIX0, RHPOIL, RPOIL0 REAL ONE INTEGER BS, BSSTR, F, FLO, FLOSTR, LOO, NB, NFIX, RDREQ, XNOTI PARAMETER (BS=85, BSSTR=86, F=10, FLO=88, FLOSTR=89, LOO=84, 1 NB=87, NFIX=83, RDREQ=57, XNOTI=90) DATA ALG/1/, KDIAG/0/, NIN/5/ DATA ALGNAM(1)/' GLG'/, ALGNAM(2)/' GLF'/ DATA ALGNAM(3)/' GLGB'/, ALGNAM(4)/' GLFB'/ DATA ONE/1.E+0/ DATA WNAME(1)/' RHO" '/, WNAME(2)/' IRLS '/, 1 WNAME(3)/' SCORE '/, WNAME(4)/'DEVIANCE'/ C C *** BODY *** C CALL IVSET(1, IV, LIV, LV, V) IV(FLO) = 16*NMAX + 5 IV(XNOTI) = IV(FLO) + NMAX IV(BS) = 7 IV(BSSTR) = 1 IV(FLOSTR) = 1 IV(LOO) = 1 IV(NB) = 5 IV(NFIX) = 0 CALL V7SCP(NMAX, RHOR(IV(FLO)), ONE) CALL V7SCP(NMAX, RHOR(IV(XNOTI)), -2.E+0) DO 10 I = IV(BS), IV(BS) + NMAX - 1 10 RHOI(I) = 1 T = R7MDC(6) DO 20 I = 1, PMAX B(1,I) = -T B(2,I) = T 20 CONTINUE NRUN = 0 MDL(6) = 1 30 READ(NIN,*,END=210) K WRITE(NW,*) '*', K GO TO (40, 50, 60, 70, 80, 90, 100, 110, 170, 180, 220, 1 230, 240, 250, 260, 270, 300, 310, 320, 340, 2 350, 360, 370, 380, 390, 430, 440, 450), K WRITE(NW,*) '/// Invalid command', K 40 WRITE(NW,*) '1 = LIST MENU' WRITE(NW,*) '2 = READ IV' WRITE(NW,*) '3 = READ V' WRITE(NW,*) 1 '4 = READ ALG: 1 = GLG, 2 = GLF, 3 = GLGB, 4 = GLFB' WRITE(NW,*) '5 = READ ALL OF X0' WRITE(NW,*) '6 = COPY X TO X0' WRITE(NW,*) '7 = START' WRITE(NW,*) '8 = CONTINUE' WRITE(NW,*) '9 = READ COMMANDS FROM SPECIFIED FILE' WRITE(NW,*) '10 = READ PROBLEM' WRITE(NW,*) '11 = READ RHO' WRITE(NW,*) '12 = READ MODEL' WRITE(NW,*) '13 = CHECK RHO DERIVATIVES' WRITE(NW,*) '14 = READ P' WRITE(NW,*) '15 = READ X0 COMPONENTWISE' WRITE(NW,*) '16 = read new Y' WRITE(NW,*) 1 '17 = negate RHO (negative ==> use weights; see KW = 19)' WRITE(NW,*) '18 = read KDIAG: 1 = from X*, 2 = from X0, 3 = both' WRITE(NW,*) 1 '19 = read KW: 1 = RHO", 2 = IRLS, 3 = score, 4 = deviance' WRITE(NW,*) '20 = READ B (format i, b(1,i), b(2,i))' WRITE(NW,*) '21,22 = Read,Show RHOI (componentwise)' WRITE(NW,*) '23,24 = Read,Show RHOR "' WRITE(NW,*) '25 = Show range of RHOR components' WRITE(NW,*) '26,27 = Show IV, V components' WRITE(NW,*) '28 = Read and echo comment' GO TO 30 50 READ(NIN,*,END=210) I, J IF (I .LE. 0) GO TO 30 IV(I) = J GO TO 50 60 READ(NIN,*,END=210) I, T IF (I .LE. 0) GO TO 30 V(I) = T GO TO 60 70 READ(NIN,*,END=210) ALG GO TO 30 80 READ(NIN,*,END=210) (X0(I), I = 1, P0) GO TO 30 90 CALL V7CPY(P0+3, X0, X) GO TO 30 100 CALL V7CPY(P0+3, X, X0) IV(1) = 12 110 UI(6) = M NRUN = NRUN + 1 IF (IV(1) .EQ. 0 .OR. IV(1) .EQ. 12) THEN WRITE(NW,'(/'' Run'',I5,'': calling '',A,'' with PS ='',I5)') 1 NRUN, ALGNAM(ALG), PS ELSE WRITE(NW,'(/'' Run'',I5,'': continuing '',A,'', PS ='',I5)') 1 NRUN, ALGNAM(ALG), PS END IF IF (KDIAG .GT. 0) IV(RDREQ) = 2 GO TO (120,130,140,150), ALG 120 CALL GLG(N, P, PS, X, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 160 130 CALL GLF(N, P, PS, X, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 160 140 CALL GLGB(N, P, PS, X, B, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 30 150 CALL GLFB(N, P, PS, X, B, RHPOIL, RHOI, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ) GO TO 30 160 IF (IV(1) .LT. 8) THEN CALL DEVIAN(V(F), MDL(1), N, NW, X(PS+1), YN) IF (ALG .EQ. 1) CALL LOUCHK(KDIAG, GLG, X0, N, P, PS, X, 1 RHPOIL, MDL, YN, IV, LIV, LV, V, BRJ, UI, A, BRJ) IF (ALG .EQ. 2) CALL LOUCHK(KDIAG, GLF, X0, N, P, PS, X, 1 RHPOIL, MDL, YN, IV, LIV, LV, V, BRJ, UI, A, BRJ) END IF GO TO 30 170 IF (NIN .LE. 1) THEN WRITE(NW,*) '*** TOO MANY FILES OPEN' GO TO 30 END IF READ(NIN,'(A)',END=200) FNAME NIN = NIN - 1 OPEN(NIN,FILE=FNAME,STATUS='OLD',ERR=410) REWIND NIN GO TO 30 180 READ(NIN,'(A)',END=200) FNAME IF (FNAME .EQ. '-') THEN NR = NIN ELSE OPEN(NR0,FILE=FNAME,STATUS='OLD',ERR=410) REWIND NR0 NR = NR0 END IF READ(NR, '(A)', END=200) DESC WRITE(NW,*) DESC READ(NR, '(9I4)', END=200) N, P, MODEL, M, MDL(1), I, J, PS P0 = P IF (PS .EQ. 0) PS = P IF (MODEL .LE. 2) M = PS IF (MIN(MDL(1),M,N,PS,P-PS+1,MODEL+1) .LE. 0 .OR. P .GT. PMAX 1 .OR. M .GT. MMAX) THEN WRITE(NW,*) 'INVALID PROBLEM DIMENSIONS: M, N, P, MODEL =', 1 M, N, P, MODEL STOP END IF MDL(2) = P MDL(3) = PS UI(1) = M UI(2) = MODEL UI(3) = 2 UI(4) = 0 UI(5) = 0 UI(7) = PS CALL V7SCP(3, X0(P+1), ONE) IF (MODEL .GT. 2) THEN READ(NR, *, END=200) (X0(I), I = 1, P) ELSE IF (PS .LT. P) THEN READ(NR, *, END=200) (X0(I), I = PS+1, P) END IF READ(NR, '(A)', END=200) FMT J1 = 0 DO 190 I = 1, N J0 = J1 + 1 J1 = J1 + M READ(NR, FMT, END=200) YN(1,I), YN(2,I), (A(J), J = J0, J1) C FROME*S DOCUMENTATION CLAIMS Y(I) IS YBAR(I), BUT HIS PROGRAM C ASSUMES IT IS THE TOTAL COUNT AND TURNS Y(I) INTO YBAR(I) C BY THE EQUIVALENT OF THE FOLLOWING STATEMENT... C YN(1,I) = YN(1,I) / YN(2,I) 190 CONTINUE IF (MODEL .LE. 2) THEN CALL POIX0(A, IV, PS, LIV, LV, MODEL, N, PS, V, X0, YN) END IF GO TO 30 200 WRITE(NW,*) '*** PREMATURE END OF FILE' IF (NR .NE. NIN) GO TO 30 210 IF (NIN .GE. 5) STOP NIN = NIN + 1 GO TO 30 220 READ(NIN,*,END=210) I IF (I .LE. 0) I = MDL(1) WRITE(NW,*) 'Changing RHO from ', MDL(1), ' to ', I MDL(1) = I GO TO 30 230 READ(NIN,*,END=210) I IF (I .EQ. 0) I = MODEL WRITE(NW,*) 'Changing MODEL from ', MODEL, ' to ', I MODEL = I UI(2) = MODEL GO TO 30 240 CALL CHKDER(MDL, N, P-PS, X0(PS+1), V(200), RHPOIL, RPOIL0, YN) GO TO 30 250 READ(NIN,*,END=210) I IF (I .GT. P0 .OR. I .LT. P0-3) THEN WRITE(NW,*) 'INVALID P = ', I, ' -- P REMAINS ', P ELSE P = I MDL(2) = I END IF GO TO 30 260 READ(NIN,*,END=210) I, T IF (I .LE. 0) GO TO 30 X0(I) = T GO TO 260 270 DO 280 I = 1, N 280 READ(NIN, FMT, END=290) YN(1,I), YN(2,I) GO TO 30 290 WRITE(NW,*) 'Premature end of file!' GO TO 210 300 I = 1 IF (MDL(6) .EQ. 1) I = 2 GO TO 330 310 READ(NIN,*,END=210) KDIAG GO TO 30 320 READ(NIN,*,END=210) I I = MIN(4, MAX0(I,1)) 330 WRITE(NW,*) 'KW changed from ', MDL(6), ' = ', WNAME(MDL(6)), 1 ' to ', I, ' = ', WNAME(I) MDL(6) = I GO TO 30 340 READ(NIN,*,END=210) I, T, T1 IF (I .LE. 0) GO TO 30 B(1,I) = T B(2,I) = T1 GO TO 340 350 READ(NIN,*,END=210) I, J IF (I .LE. 0) GO TO 30 RHOI(I) = J GO TO 350 360 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'RHOI(',I,') = ', RHOI(I) GO TO 360 370 READ(NIN,*,END=210) I, T IF (I .LE. 0) GO TO 30 RHOR(I) = T GO TO 370 380 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'RHOR(',I,') = ', RHOR(I) GO TO 380 390 READ(NIN,*,END=210) I, J IF (I .LE. 0) GO TO 30 WRITE(*,*) (RHOR(K), K = I, J) GO TO 390 410 WRITE(*,420) FNAME 420 FORMAT(' Can''t open ',A) GO TO 30 430 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'IV(',I,') = ', IV(I) GO TO 430 440 READ(NIN,*,END=210) I IF (I .LE. 0) GO TO 30 WRITE(*,*) 'V(',I,') = ', V(I) GO TO 440 450 READ(NIN,'(A)',END=200) FNAME WRITE(NW,*) FNAME GO TO 30 END SUBROUTINE BRJ(N, P, X, NF, NEED, R, RP, UI, A, UF) INTEGER N, P, NF, NEED(2), UI(5) REAL X(P), R(N), RP(P,N), A(*) EXTERNAL UF EXTERNAL BRJ1 INTEGER M C C *** BODY *** C M = UI(6) CALL BRJ1(M, N, UI(7), X, NF, NEED, R, RP, UI, A, A(M*N+1), UF) 999 RETURN END SUBROUTINE BRJ1(M, N, P, X, NF, NEED, R, RP, UI, A, UR, UF) INTEGER M, N, P, NF, NEED(2), UI(5) REAL X(P), R(N), RP(P,N), A(M,N), UR(N,6) EXTERNAL UF EXTERNAL D7TPR, R7MDC REAL D7TPR, R7MDC C C *** LOCAL VARIABLES *** C INTEGER I, J, J2, J4, MODEL REAL ALPHA, BETA1, BETA2, DI, E, EMX, PHI, T, T1, 1 THETA, TI, X1, X1INV, X2, X3, X3M1, X4 REAL EXPMAX, EXPMIN, ONE, TWO, ZERO DATA EXPMAX/0.E+0/, EXPMIN/0.E+0/, ONE/1.E+0/, TWO/2.E+0/, 1 ZERO/0.E+0/ C C *** BODY *** C MODEL = IABS(UI(2)) IF (MODEL .LE. 0) GO TO 520 IF (MODEL .GT. 11) GO TO 520 IF (EXPMAX .GT. ZERO) GO TO 10 EXPMAX = TWO * ALOG( R7MDC(5)) EXPMIN = TWO * ALOG( R7MDC(2)) 10 IF (NEED(1) .EQ. 2) GO TO 260 J = 3 - UI(3) IF (UI(3+J) .EQ. NEED(2)) J = UI(3) UI(3) = J UI(3+J) = NF J2 = J + 2 J4 = J + 4 GO TO (20, 40, 60, 60, 80, 100, 120, 170, 190, 210, 230), MODEL C C *** LINEAR MODEL *** C 20 DO 30 I = 1, N 30 R(I) = D7TPR(P, X, A(1,I)) GO TO 999 C C *** EXPONENTIAL OF LINEAR *** C 40 DO 50 I = 1, N T = D7TPR(P, X, A(1,I)) IF (T .GE. EXPMAX) GO TO 520 E = ZERO IF (T .GT. EXPMIN) E = EXP(T) R(I) = E UR(I,J) = E 50 CONTINUE GO TO 999 C C *** NONLINEAR POISSON EXAMPLE FROM FROME*S PREG MANUAL *** C 60 X1 = X(1) X2 = X(2) X3 = X(3) DO 70 I = 1, N E = EXP(-X2*A(2,I)) UR(I,J2) = E T = (ONE - E) ** X3 UR(I,J4) = T T = X1*A(1,I) * (ONE - T) IF (T .LE. ZERO) GO TO 520 UR(I,J) = T IF (MODEL .EQ. 3) T = ALOG(T) R(I) = T 70 CONTINUE GO TO 999 C C *** CAESIUM DOSE EFFECT MODEL *** C 80 X1 = X(1) X2 = X(2) X3 = X(3) DO 90 I = 1, N DI = A(1,I) TI = A(2,I) IF (X3 .EQ. ZERO) GO TO 520 IF (TI .EQ. ZERO) GO TO 520 T = -TI / X3 IF (T .GE. EXPMAX) GO TO 520 E = ZERO IF (T .GT. EXPMIN) E = EXP(T) UR(I,J) = E T = X3 / TI T = DI * (X2 + TWO*T*DI*(ONE - T*(ONE - E))) UR(I,J2) = T R(I) = X1 * T 90 CONTINUE GO TO 999 C C *** LUNG CANCER MODEL *** C 100 X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) EMX = EXPMAX - 10.E+0 DO 110 I = 1, N T1 = X1 * A(1,I) T = X2 + X3*A(2,I) + T1 IF (T .GE. EMX) GO TO 520 E = ZERO IF (T .GT. EXPMIN) E = EXP(T) T = X4 + T1 IF (T .GE. EMX) GO TO 520 T1 = ZERO IF (T .GT. EXPMIN) T1 = EXP(T) T = E + T1 R(I) = T UR(I,J) = E UR(I,J2) = T1 UR(I,J4) = T 110 CONTINUE GO TO 999 C C *** LOGISTIC OF LINEAR *** C 120 DO 160 I = 1, N T = D7TPR(P, A(1,I), X) IF (T .LE. EXPMIN) GO TO 130 IF (T .GE. EXPMAX) GO TO 140 E = EXP(T) T1 = ONE / (ONE + E) T = E * T1 T1 = T * T1 GO TO 150 130 T = ZERO T1 = ZERO GO TO 150 140 T = ONE T1 = ZERO 150 R(I) = T UR(I,J) = T1 160 CONTINUE GO TO 999 C C *** LOG OF LINEAR *** C 170 DO 180 I = 1, N T = D7TPR(P, X, A(1,I)) IF (T .LE. ZERO) GO TO 520 R(I) = ALOG(T) UR(I,J) = T 180 CONTINUE GO TO 999 C C *** EXAMPLE ON P. 204 OF MCCULLAGH AND NELDER *** C 190 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) DO 200 I = 1, N X2 = A(2,I) R(I) = ALPHA + BETA1*ALOG(A(1,I)) + BETA2*X2/(PHI + X2) 200 CONTINUE GO TO 999 C C *** EXAMPLE ON P. 205 OF MCCULLAGH AND NELDER *** C 210 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) THETA = X(5) DO 220 I = 1, N X2 = A(2,I) T = A(1,I) - THETA IF (T .LE. ZERO) GO TO 520 R(I) = ALPHA + BETA1*ALOG(T) + BETA2*X2/(PHI + X2) 220 CONTINUE GO TO 999 C C *** EXAMPLE P. 202 OF MCCULLAGH AND NELDER *** C 230 DO 250 I = 1, N T = X(1) DO 240 J = 1, 3 T1 = A(J,I) + X(2*J+1) IF (T1 .LE. ZERO) GO TO 520 240 T = T + X(2*J)/T1 R(I) = T 250 CONTINUE GO TO 999 C C *** JACOBIAN EVALUATIONS... C 260 J = UI(3) IF (NF .EQ. UI(J+3)) GO TO 270 J = 3 - J IF (NF .EQ. UI(J+3)) GO TO 270 WRITE(6,*) 'HELP! UNAVAILABLE INTERMEDIATE INFO!' GO TO 520 270 J2 = J + 2 J4 = J + 4 GO TO (280, 290, 310, 340, 370, 390, 410, 430, 450, 470, 490), 1 MODEL C C *** LINEAR MODEL *** C C 280 CALL V7CPY(N*P, RP, A) GO TO 999 C C *** EXPONENTIAL OF LINEAR MODEL *** C 290 DO 300 I = 1, N 300 CALL V7SCL(P, RP(1,I), UR(I,J), A(1,I)) GO TO 999 C C *** LOG OF NONLINEAR POISSON EXAMPLE FROM FROME*S PREG MANUAL *** C 310 X1 = X(1) X2 = X(2) X3 = X(3) X3M1 = X3 - ONE X1INV = ONE / X1 DO 330 I = 1, N RP(1,I) = X1INV E = UR(I,J2) T1 = ONE - E T = -A(1,I) * X1 / UR(I,J) RP(2,I) = T * X3 * A(2,I) * E * T1**X3M1 IF (T1 .LE. ZERO) GO TO 320 RP(3,I) = T * UR(I,J4) * ALOG(T1) GO TO 330 320 RP(3,I) = ZERO 330 CONTINUE GO TO 999 C C *** NONLINEAR POISSON EXAMPLE FROM FROME*S PREG MANUAL *** C 340 X1 = X(1) X2 = X(2) X3 = X(3) X3M1 = X3 - ONE X1INV = ONE / X1 DO 360 I = 1, N RP(1,I) = A(1,I) * (ONE - UR(I,J4)) E = UR(I,J2) T1 = ONE - E T = -A(1,I) * X1 RP(2,I) = T * X3 * A(2,I) * E * T1**X3M1 IF (T1 .LE. ZERO) GO TO 350 RP(3,I) = T * UR(I,J4) * ALOG(T1) GO TO 360 350 RP(3,I) = ZERO 360 CONTINUE GO TO 999 C C *** CAESIUM DOSE EFFECT MODEL *** C 370 X1 = X(1) X3 = X(3) DO 380 I = 1, N RP(1,I) = UR(I,J2) DI = A(1,I) TI = A(2,I) RP(2,I) = X1 * DI E = UR(I,J) T = TWO * X3 / TI RP(3,I) = TWO * X1 * (DI/TI) * DI * (ONE - T + E*(T + ONE)) 380 CONTINUE GO TO 999 C C *** LUNG CANCER MODEL *** C 390 DO 400 I = 1, N RP(1,I) = UR(I,J4) * A(1,I) T = UR(I,J) RP(2,I) = T RP(3,I) = T * A(2,I) RP(4,I) = UR(I,J2) 400 CONTINUE GO TO 999 C C *** LOGISTIC OF LINEAR *** C 410 DO 420 I = 1, N 420 CALL V7SCL(P, RP(1,I), UR(I,J), A(1,I)) GO TO 999 C C *** LOG OF LINEAR *** C 430 DO 440 I = 1, N 440 CALL V7SCL(P, RP(1,I), ONE/UR(I,J), A(1,I)) GO TO 999 C C *** EXAMPLE ON P. 204 OF MCCULLAGH AND NELDER *** C 450 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) DO 460 I = 1, N X2 = A(2,I) C R(1,I) = ALPHA + BETA1*ALOG(A(1,I)) + BETA2*X2/(PHI + X2) RP(1,I) = ONE RP(2,I) = ALOG(A(1,I)) RP(3,I) = X2/(PHI + X2) RP(4,I) = -BETA2*X2/(PHI + X2)**2 RP(1,I) = ONE 460 CONTINUE GO TO 999 C C C *** EXAMPLE ON P. 205 OF MCCULLAGH AND NELDER *** C 470 ALPHA = X(1) BETA1 = X(2) BETA2 = X(3) PHI = X(4) THETA = X(5) DO 480 I = 1, N X2 = A(2,I) C R(I) = ALPHA + BETA1*ALOG(A(1,I) - THETA) + BETA2*X2/(PHI + X2) RP(1,I) = ONE RP(2,I) = ALOG(A(1,I) - THETA) RP(3,I) = X2/(PHI + X2) RP(4,I) = -BETA2*X2/(PHI + X2)**2 RP(5,I) = -BETA1/(A(1,I) - THETA) 480 CONTINUE GO TO 999 C C *** EXAMPLE P. 202 OF MCCULLAGH AND NELDER *** C 490 DO 510 I = 1, N C DO 453 J = 1, 3 C453 RI = RI + X(2*J)/(A(J,I) + X(2*J+1)) RP(1,I) = ONE DO 500 J = 1, 3 T = ONE / (A(J,I) + X(2*J+1)) RP(2*J,I) = T RP(2*J+1,I) = -X(2*J)*T*T 500 CONTINUE 510 CONTINUE GO TO 999 520 NF = 0 999 RETURN END SUBROUTINE CHKDER(MDL, N, NPT, PT, R, RHO, RHO0, YN) INTEGER MDL(1), N, NPT C REAL PT(NPT) -- BUT NPT MAY BE 0 REAL PT(1), R(N,20), YN(2,N) EXTERNAL RHO, RHO0 EXTERNAL V2NRM REAL V2NRM INTEGER I, J REAL F, H, T REAL FOO(10), FAC DATA FOO/.1, -.1, .2, -.2, .4, -.4, .6, -.6, .8, -.9/, H/.001E0/ C C *** BODY *** C J = 1 FAC = 1.0 DO 10 I = 1, N T = FAC * FOO(J) R(I,1) = T R(I,10) = T + H J = J + 1 IF (J .LE. 10) GO TO 10 J = 1 FAC = 10. * FAC 10 CONTINUE CALL RHO0(MDL, N, PT, R, R(1,4), YN) CALL RHO0(MDL, N, PT, R(1,10), R(1,13), YN) DO 20 I = 1, N T = R(I,10) - R(I,1) IF (T .NE. 0.E0) T = 1.E0 / T R(I,20) = T 20 CONTINUE CALL V2AXY(N, R(1,13), -1.E0, R(1,4), R(1,13)) CALL V7VMP(N, R(1,13), R(1,13), R(1,20), 1) J = 1 CALL RHO(0, F, N, J, PT, R, R(1,4), MDL, YN) CALL RHO(1, F, N, J, PT, R, R(1,4), MDL, YN) CALL V2AXY(N, R(1,19), -1.E0, R(1,13), R) T = V2NRM(N,R(1,19))/( V2NRM(N,R(1,13)) + V2NRM(N,R)) WRITE(6,*) '1ST DERIV RELATIVE DIFFERENCE =', T IF (T .GT. .01) THEN WRITE(6,*) 'I FD(I) AN(I)' WRITE(6,'(I5,2G13.4)') (I, R(I,13), R(I,1), I = 1, N) END IF CALL RHO(0, F, N, J, PT, R(1,10), R(1,13), MDL, YN) CALL RHO(1, F, N, J, PT, R(1,10), R(1,13), MDL, YN) CALL V2AXY(N, R(1,19), -1.E0, R, R(1,10)) CALL V7VMP(N, R(1,19), R(1,19), R(1,20), 1) CALL V2AXY(N, R(1,13), -1.E0, R(1,19), R(1,4)) T = V2NRM(N,R(1,13))/( V2NRM(N,R(1,4)) + V2NRM(N,R(1,19))) WRITE(6,*) '2ND DERIV RELATIVE DIFFERENCE =', T IF (T .GT. .01) THEN WRITE(6,*) 'I FD(I) AN(I)' WRITE(6,'(I5,2G13.4)') (I, R(I,19), R(I,4), I = 1, N) END IF 999 RETURN END SUBROUTINE RPOIL0(MDL, N, PT, R, RHO, YN) INTEGER N, MDL(1) REAL PT(1), R(N), RHO(N), YN(2,N) EXTERNAL LPN, R7MDC REAL LPN, R7MDC INTEGER I, MODEL REAL E, RI, T, YI REAL EXP, ALOG REAL EXPMAX, EXPMIN, HALF, ONE, TWO, ZERO DATA EXPMAX/0.E+0/, EXPMIN/0.E+0/, 1 HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/ C C *** BODY *** C MODEL = MDL(1) I = MODEL + 2 IF (I .LE. 0 .OR. I .GT. 11) THEN WRITE(6,*) 'HELP! RPOIL0 HAS MODEL =', MODEL STOP END IF IF (EXPMAX .GT. ZERO) GO TO 10 EXPMAX = TWO * ALOG( R7MDC(5)) EXPMIN = TWO * ALOG( R7MDC(2)) 10 GO TO (20, 20, 40, 60, 80, 80, 100, 120, 140, 160, 180), I C C *** POISSON RHO (AND CONVENTIONAL IRLS) *** C 20 DO 30 I = 1, N RI = R(I) IF (RI .LE. ZERO) THEN RI = ONE R(I) = ONE END IF RHO(I) = YN(2,I)*RI - YN(1,I)*ALOG(RI) 30 CONTINUE GO TO 999 C C *** LOG LINEAR *** C 40 DO 50 I = 1, N E = ZERO RI = R(I) IF (RI .GT. EXPMAX) THEN RI = HALF * EXPMAX R(I) = RI END IF IF (RI .GT. EXPMIN) E = EXP(RI) RHO(I) = YN(2,I)*E - YN(1,I)*RI 50 CONTINUE GO TO 999 C C *** SQUARE-ROOT LINEAR POISSON *** C 60 DO 70 I = 1, N RI = R(I) IF (RI .LE. ZERO) THEN RI = ONE R(I) = RI END IF RHO(I) = YN(2,I)*RI**2 - TWO*YN(1,1)*ALOG(RI) 70 CONTINUE GO TO 999 C C *** BINOMIAL RHO (AND CONVENTIONAL IRLS) *** C 80 DO 90 I = 1, N RI = R(I) IF (RI .LE. ZERO .OR. RI .GE. ONE) THEN RI = HALF R(I) = RI END IF RHO(I) = -YN(1,I)*ALOG(RI) - (YN(2,I) - YN(1,I))*ALOG(ONE-RI) 90 CONTINUE GO TO 999 C C *** BINOMIAL LOGISTIC RHO *** C 100 DO 110 I = 1, N RI = R(I) IF (RI .GT. EXPMAX) THEN RI = HALF * EXPMAX R(I) = RI END IF E = ZERO IF (RI .GT. EXPMIN) E = EXP(RI) RHO(I) = YN(2,I)*ALOG(ONE + E) - YN(1,I)*RI 110 CONTINUE GO TO 999 C C *** PROBIT *** C 120 DO 130 I = 1, N RI = R(I) YI = YN(1,I) RHO(I) = -YI*LPN(RI) - (YN(2,I)-YI)*LPN(-RI) 130 CONTINUE GO TO 999 C C *** WEIBULL *** C 140 DO 150 I = 1, N RI = R(I) IF (RI .GT. EXPMAX) THEN RI = HALF * EXPMAX R(I) = RI END IF E = ZERO IF (RI .GT. EXPMIN) E = EXP(RI) T = ZERO IF (-E .GT. EXPMIN) T = EXP(-E) RHO(I) = (YN(2,I) - YN(1,I))*E - YN(1,I)*ALOG(ONE - T) 150 CONTINUE GO TO 999 C C *** GAMMA ERRORS *** C 160 DO 170 I = 1, N RI = R(I) IF (RI .LE. ZERO) THEN WRITE(6,*) 'HELP! CHKDER HAS R(',I,') =', RI,' < 0' STOP END IF RHO(I) = YN(2,I) * (YN(1,I)*RI - ALOG(RI)) 170 CONTINUE GO TO 999 C C *** PREGIBON ERRORS *** C C *** IN THIS CASE, YN(1,I) = Y(I), YN(2,I) = LOG(Y(I)) C *** AND YN(I,J), J = N+1(1)2*N, I = 1 OR 2 = SCRATCH C 180 DO 190 I = 1, N IF (R(I) .LT. ZERO) R(I) = -R(I) 190 CONTINUE CALL PRGRH1(N, PT, R, RHO, MDL, YN) C 999 RETURN END SUBROUTINE DEVIAN(F, MODEL0, N, NW, PT, YN) INTEGER MODEL0, N, NW REAL F, PT(2), YN(2,N) REAL ATAN, ALOG INTEGER I, MODEL REAL CI, D, S, T, T1, YI REAL EIGHT, HALF, ONE, TWO, ZERO DATA EIGHT/8.E+0/, HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, 1 ZERO/0.E+0/ C C *** BODY *** C D = F MODEL = IABS(MODEL0) IF (MODEL .LT. 5) GO TO 20 IF (MODEL .GT. 9) GO TO (40, 60, 999, 80) MODEL - 9 C C *** BINOMIAL DEVIANCE *** C DO 10 I = 1, N YI = YN(1,I) CI = YN(2,I) T = YI / CI IF (T .GT. ZERO) D = D + YI*ALOG(T) IF (T .LT. ONE) D = D + (CI-YI)*ALOG(ONE-T) 10 CONTINUE GO TO 100 C C *** POISSON DEVIANCE *** C 20 DO 30 I = 1, N YI = YN(1,I) IF (YI .GT. ZERO) D = D + YI*(ALOG(YI/YN(2,I)) - ONE) 30 CONTINUE GO TO 100 C C *** GAMMA DEVIANCE *** C 40 DO 50 I = 1, N YI = YN(1,I) IF (YI .LE. ZERO) GO TO 999 D = D - YN(2,I)*(ONE + ALOG(YI)) 50 CONTINUE GO TO 100 C C *** PREGIBON DEVIANCE, REPLICATE WEIGHTS *** C 60 T = PT(2) T1 = ALOG(EIGHT* ATAN(ONE)*PT(1)) S = ZERO DO 70 I = 1, N 70 S = S + YN(2,I) * (T*ALOG(REAL(YN(1,I))) + T1) D = PT(1) * (D - HALF*S) GO TO 100 C C *** PREGIBON DEVIANCE, VARIANCE WEIGHTS *** C 80 S = ZERO T = ZERO DO 90 I = 1, N S = S + ALOG(REAL(YN(1,I))) T = T + ALOG(REAL(YN(2,I))) 90 CONTINUE D = PT(1) * (D - 1 HALF*(PT(2)*S - T + N*ALOG(EIGHT* ATAN(ONE)*PT(1)))) C 100 WRITE(NW,*) 'DEVIANCE = ', TWO*D 999 RETURN END REAL FUNCTION DZERO(F,A,B,T) C *** THE PORT ROUTINE, MODIFIED TO STOP RATHER THAN CALLING SETERR *** C *** AND TO CALL R7MDC RATHER THAN D1MACH *** C C FINDS THE REAL ROOT OF THE FUNCTION F LYING BETWEEN A AND B C TO WITHIN A TOLERANCE OF C C 6*D1MACH(3) * ABS(DZERO) + 2 * T C C F(A) AND F(B) MUST HAVE OPPOSITE SIGNS C C THIS IS BRENTS ALGORITHM C C A, STORED IN SA, IS THE PREVIOUS BEST APPROXIMATION (I.E. THE OLD B) C B, STORED IN SB, IS THE CURRENT BEST APPROXIMATION C C IS THE MOST RECENTLY COMPUTED POINT SATISFYING F(B)*F(C) .LT. 0 C D CONTAINS THE CORRECTION TO THE APPROXIMATION C E CONTAINS THE PREVIOUS VALUE OF D C M CONTAINS THE BISECTION QUANTITY (C-B)/2 C REAL F,A,B,T,TT,SA,SB,C,D,E,FA,FB,FC,TOL,M,P,Q,R,S EXTERNAL F REAL R7MDC C TT = T IF (T .LE. 0.0E0) TT = 10.E0* R7MDC(1) C SA = A SB = B FA = F(SA) FB = F(SB) IF (FA .NE. 0.0E0) GO TO 5 DZERO = SA RETURN 5 IF (FB .EQ. 0.0E0) GO TO 140 IF ( SIGN(FA,FB) .EQ. FA) THEN WRITE(*,*) 'DZERO: F(A) = ', FA, '; F(B) = ', FB STOP END IF C 10 C = SA FC = FA E = SB-SA D = E C C INTERCHANGE B AND C IF ABS F(C) .LT. ABS F(B) C 20 IF ( ABS(FC).GE. ABS(FB)) GO TO 30 SA = SB SB = C C = SA FA = FB FB = FC FC = FA C 30 TOL = 2.0E0* R7MDC(3)* ABS(SB)+TT M = 0.5E0*(C-SB) C C SUCCESS INDICATED BY M REDUCES TO UNDER TOLERANCE OR C BY F(B) = 0 C IF (( ABS(M).LE.TOL).OR.(FB.EQ.0.0E0)) GO TO 140 C C A BISECTION IS FORCED IF E, THE NEXT-TO-LAST CORRECTION C WAS LESS THAN THE TOLERANCE OR IF THE PREVIOUS B GAVE C A SMALLER F(B). OTHERWISE GO TO 40. C IF (( ABS(E).GE.TOL).AND.( ABS(FA).GE. ABS(FB))) GO TO 40 E = M D = E GO TO 100 40 S = FB/FA C C QUADRATIC INTERPOLATION CAN ONLY BE DONE IF A (IN SA) C AND C ARE DIFFERENT POINTS. C OTHERWISE DO THE FOLLOWING LINEAR INTERPOLATION C IF (SA.NE.C) GO TO 50 P = 2.0E0*M*S Q = 1.0E0-S GO TO 60 C C INVERSE QUADRATIC INTERPOLATION C 50 Q = FA/FC R = FB/FC P = S*(2.0E0*M*Q*(Q-R)-(SB-SA)*(R-1.0E0)) Q = (Q-1.0E0)*(R-1.0E0)*(S-1.0E0) 60 IF (P.LE.0.0E0) GO TO 70 Q = -Q GO TO 80 70 P = -P C C UPDATE THE QUANTITIES USING THE NEWLY COMPUTED C INTERPOLATE UNLESS IT WOULD EITHER FORCE THE C NEW POINT TOO FAR TO ONE SIDE OF THE INTERVAL C OR WOULD REPRESENT A CORRECTION GREATER THAN C HALF THE PREVIOUS CORRECTION. C C IN THESE LAST TWO CASES - DO THE BISECTION C BELOW (FROM STATEMENT 90 TO 100) C 80 S = E E = D IF ((2.0E0*P.GE.3.0E0*M*Q- ABS(TOL*Q)).OR. 1 (P.GE. ABS(0.5E0*S*Q))) GO TO 90 D = P/Q GO TO 100 90 E = M D = E C C SET A TO THE PREVIOUS B C 100 SA = SB FA = FB C C IF THE CORRECTION TO BE MADE IS SMALLER THAN C THE TOLERANCE, JUST TAKE A DELTA STEP (DELTA=TOLERANCE) C B = B + DELTA * SIGN(M) C IF ( ABS(D).LE.TOL) GO TO 110 SB = SB+D GO TO 130 C 110 IF (M.LE.0.0E0) GO TO 120 SB = SB+TOL GO TO 130 C 120 SB = SB-TOL 130 FB = F(SB) C C IF F(B) AND F(C) HAVE THE SAME SIGN ONLY C LINEAR INTERPOLATION (NOT INVERSE QUADRATIC) C CAN BE DONE C IF ((FB.GT.0.0E0).AND.(FC.GT.0.0E0)) GO TO 10 IF ((FB.LE.0.0E0).AND.(FC.LE.0.0E0)) GO TO 10 GO TO 20 C C***SUCCESS*** 140 DZERO = SB RETURN END REAL FUNCTION INVCN(X, ERRFLG) REAL X INTEGER ERRFLG COMMON /INVCMN/ XC, TOL, NCALL REAL XC, TOL INTEGER NCALL REAL CNERR, DZERO, PNORMS, R7MDC EXTERNAL CNERR, PNORMS, R7MDC REAL A, B REAL HALF, ONE, ZERO LOGICAL FIRST REAL HUGE PARAMETER (HALF = 0.5E+0, ONE = 1.E+0, ZERO = 0.E+0) SAVE FIRST, HUGE DATA FIRST/.TRUE./, HUGE/0.E+0/ IF (FIRST) THEN TOL = 10.E+0 * R7MDC(1) HUGE = 0.1E+0 * R7MDC(6) FIRST = .FALSE. END IF NCALL = 0 ERRFLG = 0 IF (X .LE. ZERO) THEN C IF (X .EQ. ZERO) THEN C INVCN = -HUGE C GO TO 999 C END IF ERRFLG = 1 INVCN = ZERO GO TO 999 END IF IF (X .GE. ONE) THEN C IF (X .EQ. ONE) THEN C INVCN = HUGE C GO TO 999 C END IF ERRFLG = 1 INVCN = ZERO GO TO 999 END IF IF (X .GE. HALF) THEN A = ZERO B = ONE 10 IF (PNORMS(B) .LT. X) THEN B = B + ONE GO TO 10 END IF ELSE B = ZERO A = -ONE 20 IF (PNORMS(A) .GT. X) THEN A = A - ONE GO TO 20 END IF END IF XC = X INVCN = DZERO(CNERR,A,B,TOL) 999 RETURN END REAL FUNCTION CNERR(X) REAL X COMMON /INVCMN/ XC, TOL, NCALL REAL XC, TOL INTEGER NCALL REAL PNORMS EXTERNAL PNORMS NCALL = NCALL + 1 CNERR = XC - PNORMS(X) END SUBROUTINE LOUCHK(KDIAG, GLG, X0, N, P, PS, X, RHPOIL, MDL, YN, 1 IV, LIV, LV, V, BRJ, UI, A, BRJ1) EXTERNAL GLG, RHPOIL, BRJ, BRJ1 INTEGER KDIAG, N, P, PS, LIV, LV INTEGER IV(LIV), MDL(2), UI(*) REAL X0(P), X(P), V(LV), A(*), YN(N) C C *** DUMMY REPLACEMENT FOR C ROUTINE (USED FOR DEBUGGING) *** C END REAL FUNCTION PNORMS(X) REAL X EXTERNAL MECDF REAL D(1), PROB, RHO(1) INTEGER IER D(1) = X CALL MECDF(1, D, RHO, PROB, IER) PNORMS = 1.E+0 - PROB END SUBROUTINE POISX0(A, C, LA, LC, MODEL, N, P, QTR, X, YN) INTEGER LA, LC, MODEL, N, P REAL A(LA,N), C(LC), QTR(P), X(P), YN(2,N) EXTERNAL L7ITV, L7SVX, L7SVN, Q7ADR, R7MDC, V7SCL, V7SCP REAL L7SVX, L7SVN, R7MDC INTEGER I REAL SX, W, WRT, WY, YN1 REAL HALF, ONE, ZERO DATA HALF/0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ C C *** BODY *** C CALL V7SCP(LC, C, ZERO) CALL V7SCP(P, QTR, ZERO) DO 30 I = 1, N W = YN(2,I) IF (W .LE. ZERO) GO TO 40 WRT = SQRT(W) YN1 = YN(1,I) / YN(2,I) IF (MODEL .EQ. 2) GO TO 10 WY = WRT * YN1 GO TO 20 10 WY = WRT * ALOG( MAX(YN1, HALF/W)) 20 CALL V7SCL(P, X, WRT, A(1,I)) CALL Q7ADR(P, QTR, C, X, WY) 30 CONTINUE SX = L7SVX(P, C, X, X) IF (SX .LE. ZERO) GO TO 40 IF ( L7SVN(P, C, X, X)/SX .LE. R7MDC(3)) GO TO 40 CALL L7ITV(P, X, C, QTR) GO TO 999 40 W = ONE IF (MODEL .EQ. 2) W = ZERO CALL V7SCP(P, X, W) C 999 RETURN END SUBROUTINE POIX0(A, IV, LA, LIV, LV, MODEL, N, P, V, X, YN) C C *** COMPUTE INITIAL X OF E. L. FROME *** C INTEGER LA, LIV, LV, MODEL, N, P INTEGER IV(LIV) REAL X(P), A(LA,N), V(LV), YN(2,N) C EXTERNAL IVSET, POISX0, V7SCP C C *** LOCAL VARIABLES *** C INTEGER C1, PP1O2, QTR1, TEMP1 REAL ONE, ZERO C C *** IV COMPONENTS *** C INTEGER LMAT PARAMETER (LMAT=42) DATA ONE/1.E+0/, ZERO/0.E+0/ C C--------------------------------- BODY ------------------------------ C IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V) C C1 = IV(LMAT) PP1O2 = P * (P + 1) / 2 QTR1 = C1 + PP1O2 TEMP1 = QTR1 + P IF (TEMP1 .GT. LV) GO TO 10 CALL POISX0(A, V(C1), LA, P*(P+1)/2, MODEL, N, P, V(QTR1), X, YN) GO TO 999 C 10 IF (MODEL .GT. 1) GO TO 20 CALL V7SCP(P, X, ONE) GO TO 999 20 CALL V7SCP(P, X, ZERO) C 999 RETURN END SUBROUTINE PREGRH(DERIV, F, N, NF, PT, R, RD, RHOI, YLOG, YN, ZN) C C *** RHO FOR PREGIBON ERROR MODELS WITH REPLICATE WEIGHTS *** C *** SEE PREGRV FOR THE RIGHT WEIGHTING FOR THE INSURANCE EXAMPLE *** C INTEGER DERIV, N, NF, RHOI(*) REAL F, PT(3), R(*), RD(*), YLOG(*), YN(2,N), ZN(3,N) EXTERNAL R7MDC REAL R7MDC C C *** LOCAL VARIABLES *** C INTEGER I, K, KMP, KMPS, KMT, KPP, KPPS, KPSPS, KPT, KTT, KTPS REAL F1, MU, PHI, PHII2, PHII3, PHIINV, PSI, PSPHII, 1 RI, RL, RP0, RPP0, RT1, RT1L, RT2, RT2L, RTOL, T, 2 T1, T1INV, T1INV2, T2, T2INV, T2INV2, THETA, TT, 3 WI, WOVPHI, YI, YL, YT1, YT1L, YT2, YT2L C REAL BIG, BIGH, TWOPI REAL BTOL, EIGHT, HALF, ONE, THREE, TWO, ZERO DATA BIG/0.E+0/, BIGH/0.E+0/, TWOPI/0.E+0/ DATA BTOL/1.01E+0/, EIGHT/8.E+0/, HALF/0.5E+0/, ONE/1.E+0/, 1 THREE/3.E+0/, TWO/2.E+0/, ZERO/0.E+0/ C C *** BODY *** C IF (NF .GT. 1) GO TO 20 IF (DERIV .GT. 0) GO TO 20 DO 10 I = 1, N 10 YLOG(I) = ALOG(YN(1,I)) 20 PHI = PT(1) PSI = PT(3) IF (PHI .LE. ZERO) GO TO 240 THETA = PT(2) IF (TWOPI .GT. ZERO) GO TO 30 TWOPI = EIGHT * ATAN(ONE) BIGH = R7MDC(5) BIG = R7MDC(6) 30 T2 = TWO - THETA T1 = ONE - THETA IF (DERIV .GT. 0) GO TO 120 RTOL = BIG IF (T2 .LT. BTOL) GO TO 40 RTOL = BIGH**(ONE/T2) RTOL = RTOL*RTOL 40 T = ALOG(TWOPI * PHI) F = ZERO DO 50 I = 1, N 50 F = F + YN(2,I)*(T + THETA*YLOG(I)) F1 = ZERO IF (THETA .EQ. ONE) GO TO 70 IF (THETA .EQ. TWO) GO TO 90 T1INV = ONE / T1 T2INV = ONE / T2 DO 60 I = 1, N RI = R(I) IF (RI .GE. RTOL) GO TO 240 IF (RI .LE. ZERO) GO TO 240 YI = YN(1,I) RT1 = RI**(T1*PSI) ZN(2,I) = RT1 YT1 = YI**T1 ZN(3,I) = YT1 T = T2INV*(RI**(T2*PSI) - YI*YT1) + YI*T1INV*(YT1 - RT1) F1 = F1 + T*YN(2,I) ZN(1,I) = T 60 CONTINUE GO TO 110 C C *** THETA == 1 *** C 70 DO 80 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 240 MU = RI**PSI YI = YN(1,I) T = MU - YI - YI*ALOG(MU/YI) F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = ONE 80 CONTINUE GO TO 110 C C *** THETA == 2 *** C 90 DO 100 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 240 T1 = RI**(-PSI) YI = YN(1,I) * T1 T = YI - ALOG(YI) - ONE F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = T1 100 CONTINUE 110 F = HALF*F + F1/PHI GO TO 999 C C *** GRADIENT COMPUTATIONS *** C 120 PHIINV = ONE / PHI PHII2 = PHIINV * PHIINV RP0 = HALF * PHIINV RPP0 = -PHIINV * RP0 PHII3 = TWO * PHIINV * PHII2 KMP = N KPP = N + N T1 = ONE - THETA T2 = TWO - THETA IF (RHOI(2) .LE. RHOI(3)+2) GO TO 140 C C *** PSI DERIVATIVES *** C K = KPP + N KMPS = 6*N KPPS = KMPS + N KTPS = KPPS + N KPSPS = KTPS + N DO 130 I = 1, N WI = YN(2,I) RI = R(I) MU = RI**PSI RL = ALOG(RI) RT1 = WI * ZN(2,I) RT2 = RT1 * MU YI = YN(1,I) T = (RL/PHI) * (RT2 - YI*RT1) K = K + 1 R(K) = T KMPS = KMPS + 1 TT = RL * (T2*RT2 - YI*T1*RT1) RD(KMPS) = (RT2 - YI*RT1 + PSI*TT) / (RI*PHI) KPPS = KPPS + 1 RD(KPPS) = -T / PHI KTPS = KTPS + 1 RD(KTPS) = -PSI * RL * T KPSPS = KPSPS + 1 RD(KPSPS) = TT * RL / PHI 130 CONTINUE C 140 IF (RHOI(2) .LE. RHOI(3)) GO TO 220 IF (RHOI(2) .EQ. RHOI(3)+1) GO TO 200 C C *** THETA DERIVATIVES *** C K = KPP KMT = K + N KPT = KMT + N KTT = KPT + N IF (THETA .EQ. ONE) GO TO 160 IF (THETA .EQ. TWO) GO TO 180 T1INV = ONE / T1 T1INV2 = T1INV + T1INV T2INV = ONE / T2 T2INV2 = T2INV + T2INV DO 150 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV RI = R(I) MU = RI**PSI RT1 = ZN(2,I) RT2 = RT1 * MU RL = ALOG(MU) RT1L = RT1 * RL RT2L = RT2 * RL YI = YN(1,I) YT1 = ZN(3,I) YT2 = YT1 * YI YL = YLOG(I) YT1L = YT1 * YL YT2L = YT2 * YL T = PHIINV * (YI * T1INV * (RL*RT1 - YL*YT1 + 1 T1INV*(YT1 - RT1)) 2 + T2INV * (YL*YT2 - RL*RT2 + 3 T2INV*(RT2 - YT2))) K = K + 1 R(K) = WI * (HALF*YL + T) KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI*RT1 - RT2) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 RD(KTT) = WOVPHI*(T1INV*YI*(YT1L*YL - RT1L*RL + 1 T1INV2*(RT1L - YT1L + 2 T1INV*(YT1 - RT1))) + 3 T2INV*(RT2L*RL - YT2L*YL + 4 T2INV2*(YT2L - RT2L + 5 T2INV*(RT2 - YT2)))) 150 CONTINUE GO TO 200 C C *** THETA DERIVATIVES AT THETA == 1 *** C 160 DO 170 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = ALOG(MU) K = K + 1 T = HALF*YI*(RL*RL - YL*YL) + YI*YL - MU*RL + MU - YI R(K) = WI*(HALF*YL + T) KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI - MU) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ( MU * (TWO - TWO*RL + T) 1 -YI*(TWO - T*RL/THREE + YL*(YL - TWO + YL*YL/THREE))) 170 CONTINUE GO TO 200 C C *** THETA DERIVATIVES AT THETA == 2 *** C 180 DO 190 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = ALOG(MU) K = K + 1 T = HALF*(YL*YL - RL*RL) + YL + ONE - (YI + YI*RL)/MU R(K) = WI*(HALF*YL + T) KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI/MU - ONE) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ((YL/MU)*(T + TWO*RL + TWO) - TWO 1 - YL*(TWO + YL*(ONE + YL/THREE)) + T*RL/THREE) 190 CONTINUE C C *** PHI AND MU DERIVATIVES *** C 200 K = N THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE PSPHII = PSI * PHIINV PHIINV = -PHIINV DO 210 I = 1, N WI = YN(2,I) WOVPHI = WI * PSPHII RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI T2 = WOVPHI * RT1 * (MU - YI) R(I) = T2 RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI T = ZN(1,I) K = K + 1 R(K) = WI * (RP0 - PHII2*T) KMP = KMP + 1 RD(KMP) = PHIINV * T2 KPP = KPP + 1 RD(KPP) = WI * (RPP0 + PHII3*T) 210 CONTINUE GO TO 999 C C *** JUST MU DERIVATIVES *** C 220 PHIINV = PHIINV * PSI THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE DO 230 I = 1, N WOVPHI = YN(2,I) * PHIINV RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI R(I) = WOVPHI * RT1 * (MU - YI) RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI 230 CONTINUE GO TO 999 C 240 NF = 0 C 999 RETURN END SUBROUTINE PREGRV(DERIV, F, N, NF, PT, R, RD, RHOI, YLOG, YN, ZN) C C *** RHO FOR PREGIBON ERROR MODELS WITH VARIANCE WEIGHTS *** C INTEGER DERIV, N, NF, RHOI(*) REAL F, PT(3), R(*), RD(*), YLOG(N+2),YN(2,N),ZN(3,N) EXTERNAL R7MDC REAL R7MDC C C *** LOCAL VARIABLES *** C INTEGER I, K, KMP, KMPS, KMT, KPP, KPPS, KPSPS, KPT, KTT, KTPS REAL F1, MU, PHI, PHII2, PHII3, PHIINV, PSI, PSPHII, 1 RI, RL, RP0, RPP0, RT1, RT1L, RT2, RT2L, RTOL, T, 2 T1, T1INV, T1INV2, T2, T2INV, T2INV2, THETA, TT, 3 WI, WOVPHI, YI, YL, YT1, YT1L, YT2, YT2L C REAL BIG, BIGH, TWOPI REAL BTOL, EIGHT, HALF, ONE, THREE, TWO, ZERO DATA BIG/0.E+0/, BIGH/0.E+0/, TWOPI/0.E+0/ DATA BTOL/1.01E+0/, EIGHT/8.E+0/, HALF/0.5E+0/, ONE/1.E+0/, 1 THREE/3.E+0/, TWO/2.E+0/, ZERO/0.E+0/ C C *** BODY *** C PHI = PT(1) IF (PHI .LE. ZERO) GO TO 230 IF (TWOPI .GT. ZERO) GO TO 10 TWOPI = EIGHT * ATAN(ONE) BIGH = R7MDC(5) BIG = R7MDC(6) 10 IF (NF .GT. 1) GO TO 30 IF (DERIV .GT. 0) GO TO 30 T1 = ZERO T2 = ZERO DO 20 I = 1, N T = ALOG(YN(1,I)) YLOG(I) = T T1 = T1 + T T2 = T2 + ALOG(YN(2,I)) 20 CONTINUE YLOG(N+1) = T1 YLOG(N+2) = -T2 30 PSI = PT(3) THETA = PT(2) T2 = TWO - THETA T1 = ONE - THETA IF (DERIV .GT. 0) GO TO 110 RTOL = BIG IF (T2 .LT. BTOL) GO TO 40 RTOL = BIGH**(ONE/T2) RTOL = RTOL*RTOL 40 F = N*ALOG(TWOPI*PHI) + YLOG(N+2) + THETA*YLOG(N+1) F1 = ZERO IF (THETA .EQ. ONE) GO TO 60 IF (THETA .EQ. TWO) GO TO 80 T1INV = ONE / T1 T2INV = ONE / T2 DO 50 I = 1, N RI = R(I) IF (RI .GE. RTOL) GO TO 230 IF (RI .LE. ZERO) GO TO 230 YI = YN(1,I) RT1 = RI**(T1*PSI) ZN(2,I) = RT1 YT1 = YI**T1 ZN(3,I) = YT1 T = T2INV*(RI**(T2*PSI) - YI*YT1) + YI*T1INV*(YT1 - RT1) F1 = F1 + T*YN(2,I) ZN(1,I) = T 50 CONTINUE GO TO 100 C C *** THETA == 1 *** C 60 DO 70 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 230 MU = RI**PSI YI = YN(1,I) T = MU - YI - YI*ALOG(MU/YI) F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = ONE 70 CONTINUE GO TO 100 C C *** THETA == 2 *** C 80 DO 90 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 230 T1 = RI**(-PSI) YI = YN(1,I) * T1 T = YI - ALOG(YI) - ONE F1 = F1 + T*YN(2,I) ZN(1,I) = T ZN(2,I) = T1 90 CONTINUE 100 F = HALF*F + F1/PHI GO TO 999 C C *** GRADIENT COMPUTATIONS *** C 110 PHIINV = ONE / PHI PHII2 = PHIINV * PHIINV RP0 = HALF * PHIINV RPP0 = -PHIINV * RP0 PHII3 = TWO * PHIINV * PHII2 KMP = N KPP = N + N T1 = ONE - THETA T2 = TWO - THETA IF (RHOI(2) .LE. RHOI(3)+2) GO TO 130 C C *** PSI DERIVATIVES *** C K = KPP + N KMPS = 6*N KPPS = KMPS + N KTPS = KPPS + N KPSPS = KTPS + N DO 120 I = 1, N WI = YN(2,I) RI = R(I) MU = RI**PSI RL = ALOG(RI) RT1 = WI * ZN(2,I) RT2 = RT1 * MU YI = YN(1,I) T = (RL/PHI) * (RT2 - YI*RT1) K = K + 1 R(K) = T KMPS = KMPS + 1 TT = RL * (T2*RT2 - YI*T1*RT1) RD(KMPS) = (RT2 - YI*RT1 + PSI*TT) / (RI*PHI) KPPS = KPPS + 1 RD(KPPS) = -T / PHI KTPS = KTPS + 1 RD(KTPS) = -PSI * RL * T KPSPS = KPSPS + 1 RD(KPSPS) = TT * RL / PHI 120 CONTINUE C 130 IF (RHOI(2) .LE. RHOI(3)) GO TO 210 IF (RHOI(2) .EQ. RHOI(3)+1) GO TO 190 C C *** THETA DERIVATIVES *** C K = KPP KMT = K + N KPT = KMT + N KTT = KPT + N IF (THETA .EQ. ONE) GO TO 150 IF (THETA .EQ. TWO) GO TO 170 T1INV = ONE / T1 T1INV2 = T1INV + T1INV T2INV = ONE / T2 T2INV2 = T2INV + T2INV DO 140 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV RI = R(I) MU = RI**PSI RT1 = ZN(2,I) RT2 = RT1 * MU RL = ALOG(MU) RT1L = RT1 * RL RT2L = RT2 * RL YI = YN(1,I) YT1 = ZN(3,I) YT2 = YT1 * YI YL = YLOG(I) YT1L = YT1 * YL YT2L = YT2 * YL T = PHIINV * (YI * T1INV * (RL*RT1 - YL*YT1 + 1 T1INV*(YT1 - RT1)) 2 + T2INV * (YL*YT2 - RL*RT2 + 3 T2INV*(RT2 - YT2))) K = K + 1 R(K) = HALF*YL + WI*T KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI*RT1 - RT2) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 RD(KTT) = WOVPHI*(T1INV*YI*(YT1L*YL - RT1L*RL + 1 T1INV2*(RT1L - YT1L + 2 T1INV*(YT1 - RT1))) + 3 T2INV*(RT2L*RL - YT2L*YL + 4 T2INV2*(YT2L - RT2L + 5 T2INV*(RT2 - YT2)))) 140 CONTINUE GO TO 190 C C *** THETA DERIVATIVES AT THETA == 1 *** C 150 DO 160 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = ALOG(MU) K = K + 1 T = HALF*YI*(RL*RL - YL*YL) + YI*YL - MU*RL + MU - YI R(K) = HALF*YL + WI*T KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI - MU) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ( MU * (TWO - TWO*RL + T) 1 -YI*(TWO - T*RL/THREE + YL*(YL - TWO + YL*YL/THREE))) 160 CONTINUE GO TO 190 C C *** THETA DERIVATIVES AT THETA == 2 *** C 170 DO 180 I = 1, N WI = YN(2,I) WOVPHI = WI * PHIINV YI = YN(1,I) YL = YLOG(I) RI = R(I) MU = RI**PSI RL = ALOG(MU) K = K + 1 T = HALF*(YL*YL - RL*RL) + YL + ONE - (YI + YI*RL)/MU R(K) = HALF*YL + WI*T KMT = KMT + 1 RD(KMT) = PSI * WOVPHI * RL * (YI/MU - ONE) / RI KPT = KPT + 1 RD(KPT) = -WOVPHI * T KTT = KTT + 1 T = RL * RL RD(KTT) = WOVPHI * ((YL/MU)*(T + TWO*RL + TWO) - TWO 1 - YL*(TWO + YL*(ONE + YL/THREE)) + T*RL/THREE) 180 CONTINUE C C *** PHI AND MU DERIVATIVES *** C 190 K = N THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE PSPHII = PSI * PHIINV PHIINV = -PHIINV DO 200 I = 1, N WI = YN(2,I) WOVPHI = WI * PSPHII RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI T2 = WOVPHI * RT1 * (MU - YI) R(I) = T2 RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI T = ZN(1,I) K = K + 1 R(K) = RP0 - WI*PHII2*T KMP = KMP + 1 RD(KMP) = PHIINV * T2 KPP = KPP + 1 RD(KPP) = RPP0 + WI*PHII3*T 200 CONTINUE GO TO 999 C C *** JUST MU DERIVATIVES *** C 210 PHIINV = PHIINV * PSI THETA = ONE - PSI*T1 T1 = PSI*T2 - ONE DO 220 I = 1, N WOVPHI = YN(2,I) * PHIINV RI = R(I) MU = RI**PSI YI = YN(1,I) RT1 = ZN(2,I)/RI R(I) = WOVPHI * RT1 * (MU - YI) RD(I) = WOVPHI * RT1 * (T1*MU + YI*THETA) / RI 220 CONTINUE GO TO 999 C 230 NF = 0 C 999 RETURN END SUBROUTINE PRGRH1(N, PT, R, RHO, RHOI, YN) C C *** RHO FOR PREGIBON ERROR MODELS *** C INTEGER N, RHOI(3) REAL PT(2), R(*), RHO(N), YN(2,N) C *** LOCAL VARIABLES *** C INTEGER I REAL HTHETA, PHI, RI, RT1, T, T1, T1INV, T2, T2INV, 1 THETA, YI, YT1 C REAL HALF, ONE, TWO DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/ C C *** BODY *** C PHI = PT(1) THETA = PT(2) HTHETA = HALF * THETA DO 10 I = 1, N 10 RHO(I) = HTHETA*ALOG(PHI*YN(1,I)) IF (THETA .EQ. ONE) GO TO 30 IF (THETA .EQ. TWO) GO TO 50 T1 = ONE - THETA T1INV = ONE / T1 / PHI T2 = TWO - THETA T2INV = ONE / T2 / PHI DO 20 I = 1, N RI = R(I) YI = YN(1,I) RT1 = RI**T1 YT1 = YI**T1 RHO(I) = RHO(I) + T2INV*(RI*RT1 - YI*YT1) + YI*T1INV*(YT1- RT1) 20 CONTINUE GO TO 999 30 DO 40 I = 1, N RI = R(I) YI = YN(1,I) T = RI - YI - YI*ALOG(RI/YI) RHO(I) = RHO(I) + T / PHI 40 CONTINUE GO TO 999 50 DO 60 I = 1, N YI = YN(1,I) / R(I) T = YI - ALOG(YI) - ONE RHO(I) = RHO(I) + T / PHI 60 CONTINUE 999 RETURN END SUBROUTINE RHPOIL(NEED, F, N, NF, PT, R, RD, RHOI, YN, W) COMMON /FUDGE/ NFUDGE INTEGER NFUDGE INTEGER NEED(2), N, NF, RHOI(6) REAL F, PT(3), R(*), RD(*), W(N), YN(2,N) C PT = PHI AND THETA (WHEN PS == P, I.E. RHOI(2) == RHOI(3)) C REAL INVCN, LPN, PNORMS, R7MDC EXTERNAL INVCN, LPN, PNORMS, R7MDC INTEGER ERRFLG, I, IM, WCOMP REAL CI, E, PHI, PHIRI, PHIMRI, PSI, PSI1, PSI2, 1 RI, T, T1, T2, THETA, YI REAL ATAN, EXP, ALOG, SQRT REAL CNN, EIGHT, EXPMAX, EXPMIN, FOUR, HALF, ONE, TWO, 1 TWOPI, ZERO DATA CNN/0.E+0/, EXPMAX/0.E+0/, EIGHT/8.E+0/, EXPMIN/0.E+0/, 1 FOUR/4.0E+0/, HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, 2 TWOPI/0.E+0/, ZERO/0.E+0/ C C *** BODY *** C IM = RHOI(1) WCOMP = RHOI(6) IF (IM .LE. 0) GO TO 800 IF (IM .GT. 13) GO TO 800 IF (EXPMAX .GT. ZERO) GO TO 10 EXPMAX = TWO * ALOG( R7MDC(5)) EXPMIN = TWO * ALOG( R7MDC(2)) TWOPI = EIGHT * ATAN(ONE) 10 IF (NEED(1) .EQ. 2) GO TO 240 F = ZERO GO TO (20,20,40,60,80,80,100,120,140,160,180,220,180), IM C C *** POISSON RHO (AND CONVENTIONAL IRLS) *** C 20 DO 30 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 F = F + YN(2,I)*RI - YN(1,I)*ALOG(RI) 30 CONTINUE GO TO 999 C C *** LOG LINEAR POISSON *** C 40 DO 50 I = 1, N E = ZERO RI = R(I) IF (RI .GT. EXPMAX) GO TO 800 IF (RI .GT. EXPMIN) E = EXP(RI) F = F + YN(2,I)*E - YN(1,I)*RI R(I) = E 50 CONTINUE GO TO 999 C C *** SQUARE-ROOT LINEAR POISSON *** C 60 DO 70 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 F = F + YN(2,I)*RI**2 - TWO*YN(1,1)*ALOG(RI) 70 CONTINUE GO TO 999 C C *** BINOMIAL RHO (AND CONVENTIONAL IRLS) *** C 80 DO 90 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 IF (RI .GE. ONE) GO TO 800 F = F - YN(1,I)*ALOG(RI) - (YN(2,I) - YN(1,I))*ALOG(ONE-RI) 90 CONTINUE GO TO 999 C C *** BINOMIAL LOGISTIC RHO *** C 100 DO 110 I = 1, N RI = R(I) IF (RI .GE. EXPMAX) GO TO 800 E = ZERO IF (RI .GT. EXPMIN) E = EXP(RI) F = F + YN(2,I)*ALOG(ONE + E) - YN(1,I)*RI R(I) = E 110 CONTINUE GO TO 999 C C *** PROBIT *** C 120 DO 130 I = 1, N RI = R(I) YI = YN(1,I) F = F - YI*LPN(RI) - (YN(2,I)-YI)*LPN(-RI) 130 CONTINUE IF (NFUDGE .GT. 0) WRITE(*,*) 'NFUDGE =', NFUDGE NFUDGE = 0 GO TO 999 C C *** WEIBULL *** C 140 DO 150 I = 1, N RI = R(I) IF (RI .GE. EXPMAX) GO TO 800 E = ZERO IF (RI .GT. EXPMIN) E = EXP(RI) R(I) = E T = ZERO IF (-E .GT. EXPMIN) T = EXP(-E) F = F + (YN(2,I) - YN(1,I))*E - YN(1,I)*ALOG(ONE - T) 150 CONTINUE GO TO 999 C C *** GAMMA ERRORS *** C 160 DO 170 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 F = F + YN(1,I)*RI - YN(2,I)*ALOG(RI) 170 CONTINUE GO TO 999 C C *** PREGIBON ERRORS *** C C *** IN THIS CASE, YN(1,I) = Y(I), YN(2,I) = LOG(Y(I)) C *** AND YN(I,J), J = N+1(1)2*N, I = 1 OR 2 = SCRATCH C 180 IF (NF .GT. 1) GO TO 190 RHOI(4) = 0 RHOI(5) = 0 190 I = N + N + 3 C *** THE YLOG ARRAY PASSED TO PREGRV MUST BE AT LEAST N+2 LONG IF (NEED(2) .NE. RHOI(4)) GO TO 200 I = I + 3*N RHOI(5) = NF GO TO 210 200 RHOI(4) = NF 210 IF (IM .EQ. 11) THEN CALL PREGRH(0, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) ELSE CALL PREGRV(0, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) END IF GO TO 999 C C *** LEAST-SQUARES *** C 220 DO 230 I = 1, N E = R(I) - YN(1,I) F = F + E*E 230 CONTINUE F = HALF * F GO TO 999 C 240 GO TO (250,270,310,350,400,420,460,500,570,620,660,780,660), IM C C *** IRLS POISSON DERIVATIVES *** C 250 DO 260 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 R(I) = YN(2,I) - YN(1,I) / RI RD(I) = YN(2,I) / RI 260 CONTINUE GO TO 820 C C *** POISSON DERIVATIVES *** C 270 DO 300 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 YI = YN(1,I) CI = YN(2,I) E = YI / RI R(I) = CI - E RD(I) = E / RI GO TO (300, 280, 280, 290), WCOMP 280 W(I) = CI / RI GO TO 300 290 IF (YI .LE. ZERO) THEN W(I) = HALF * CI / RI ELSE T1 = CI*RI + YI*(ALOG(E/CI) - ONE) IF (T1 .NE. ZERO) THEN T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF END IF 300 CONTINUE GO TO 810 C C *** LOG LINEAR POISSON *** C 310 DO 340 I = 1, N YI = YN(1,I) CI = YN(2,I) RI = CI*R(I) R(I) = RI - YI RD(I) = RI GO TO (340,340,320,330), WCOMP 320 T = RI/YI IF (T .EQ. ONE) THEN W(I) = YI ELSE W(I) = YI * ((T - ONE) / ALOG(T)) ENDIF GO TO 340 330 T1 = RI + YI*(ALOG(YI/RI) - ONE) IF (T1 .NE. ZERO) THEN T = RI - YI W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 340 CONTINUE IF (WCOMP .LE. 2) GO TO 820 GO TO 999 C C *** SQUARE-ROOT LINEAR POISSON *** C 350 DO 390 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 YI = YN(1,I) CI = YN(2,I) E = YI / RI R(I) = TWO * (CI*RI - E) RD(I) = TWO * (CI + E/RI) GO TO (390, 360, 370, 380), WCOMP 360 W(I) = FOUR * CI GO TO 390 370 T1 = RI - SQRT(YI/CI) IF (T1 .NE. ZERO) THEN T = CI*RI - YI/RI W(I) = (T+T) / T1 ELSE W(I) = RD(I) END IF GO TO 390 380 T1 = CI*RI*RI - YI + YI*ALOG(YI/(CI*RI*RI)) IF (T1 .NE. ZERO) THEN T = CI*RI - YI/RI T = T / T1 W(I) = T + T ELSE W(I) = RD(I) END IF 390 CONTINUE GO TO 810 C C *** IRLS BINOMIAL *** C 400 DO 410 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 IF (RI .GE. ONE) GO TO 800 YI = YN(1,I) CI = YN(2,I) T = ONE / (ONE - RI) R(I) = (CI - YI) * T - YI / RI RD(I) = T * CI / RI 410 CONTINUE GO TO 820 C C *** BINOMIAL *** C 420 DO 450 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 IF (RI .GE. ONE) GO TO 800 YI = YN(1,I) T = ONE / (ONE - RI) CI = (YN(2,I) - YI) * T YI = YI / RI R(I) = CI - YI RD(I) = T*CI + YI/RI GO TO (450,430,430,440), WCOMP 430 W(I) = T*YN(2,I) / RI GO TO 450 440 YI = YN(1,I) CI = YN(2,I) T2 = YI / CI T1 = (YI - CI)*ALOG((ONE - RI)/(ONE - T2)) + YI*ALOG(T2/RI) IF (T1 .NE. ZERO) THEN T = (CI*RI - YI)/(RI * (ONE - RI)) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 450 CONTINUE GO TO 810 C C *** BINOMIAL LOGISTIC *** C 460 DO 490 I = 1, N RI = R(I) YI = YN(1,I) CI = YN(2,I) T = ONE / (ONE + RI) T1 = T * RI * CI R(I) = T1 - YI RD(I) = T * T1 GO TO (490,490,470,480), WCOMP 470 T1 = (ONE + RI)*ALOG(RI*(CI-YI)/YI) IF (T1 .NE. ZERO) THEN W(I) = ((CI - YI)*RI - YI) / T1 ELSE W(I) = RD(I) END IF GO TO 490 480 T1 = CI*ALOG((ONE+RI)*(ONE - YI/CI)) + YI*ALOG(YI/(RI*(CI-YI))) IF (T1 .NE. ZERO) THEN T = ((CI - YI)*RI - YI) / (ONE + RI) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 490 CONTINUE IF (WCOMP .LE. 2) GO TO 820 GO TO 999 C C *** PROBIT *** C 500 IF (CNN .LE. ZERO) CNN = ONE / SQRT(TWOPI) DO 560 I = 1, N RI = R(I) YI = YN(1,I) CI = YN(2,I) - YI E = ZERO T = -HALF * RI**2 IF (T .GT. EXPMIN) E = CNN * EXP(T) PHIRI = PNORMS(RI) IF (WCOMP .EQ. 2) 1 W(I) = YN(2,I) * (E / PHIRI) * (E / (ONE - PHIRI)) IF (PHIRI .LE. ZERO) GO TO 510 PHIRI = ONE / PHIRI T1 = E*PHIRI*YI T2 = T1*(RI + PHIRI*E) T1 = -T1 GO TO 520 510 T1 = YI * (RI + ONE/RI) T2 = YI * (ONE - ONE/RI**2) 520 PHIMRI = PNORMS(-RI) IF (PHIMRI .LE. ZERO) GO TO 530 PHIMRI = ONE / PHIMRI T = E*CI*PHIMRI R(I) = T + T1 RD(I) = T*(PHIMRI*E - RI) + T2 GO TO (560,560,540,550), WCOMP 530 R(I) = CI*(RI + ONE/RI) + T1 RD(I) = CI*(ONE - ONE/RI**2) + T2 GO TO (560,560,540,550), WCOMP 540 T = RI - INVCN(YI/YN(2,I), ERRFLG) IF (ERRFLG .NE. 0) THEN WRITE(*,*) 'ERROR FROM INVCN: I, YI, YN(1,I), YN(2,I) =' 1 , I, YI, YN(1,I), YN(2,I) GO TO 800 END IF IF (T .NE. ZERO) THEN W(I) = R(I) / T ELSE W(I) = RD(I) END IF GO TO 560 550 T2 = CI CI = YN(2,I) T1 = T2*(ALOG(T2/CI) - LPN(-RI)) IF (YI .GT. ZERO) T1 = T1 + YI*(ALOG(YI/CI) - LPN(RI)) IF (T1 .NE. ZERO) THEN T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 560 CONTINUE GO TO 810 C C *** WEIBULL *** C 570 DO 610 I = 1, N RI = R(I) E = ZERO IF (-RI .GT. EXPMIN) E = EXP(-RI) T = RI / (ONE - E) CI = YN(2,I)*RI YI = YN(1,I)*T R(I) = CI - YI RD(I) = CI - YI*(ONE - E*T) GO TO (570,580,590,600), WCOMP 580 W(I) = E*CI*RI / (ONE - E) GO TO 610 590 T1 = ALOG(-RI / ALOG(ONE - YN(1,I)/YN(2,I))) IF (T1 .NE. ZERO) THEN W(I) = (CI - YI) / T1 ELSE W(I) = RD(I) END IF GO TO 610 600 YI = YN(1,I) CI = YN(2,I) T2 = YI / CI CI = CI - YI T1 = CI*(RI + ALOG(ONE - T2)) + YI*(ALOG(T2/(ONE - E))) IF (T1 .NE. ZERO) THEN T = CI - YI W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 610 CONTINUE GO TO 810 C C *** GAMMA ERRORS *** C 620 DO 650 I = 1, N RI = R(I) IF (RI .LE. ZERO) GO TO 800 C F = F + YN(1,I)*RI - YN(2,I)*ALOG(RI) T = YN(2,I)/RI T1 = ONE R(I) = YN(1,I) - T RD(I) = T/RI GO TO (650,650,630,640), WCOMP 630 W(I) = YN(1,I) / RI GO TO 650 640 T2 = YN(1,I) * RI / YN(2,I) T1 = T2 - ONE T = T1*RD(I)*T1 IF (T .GT. ZERO) THEN T2 = T1 - ALOG(T2) T = T / (T2+T2) END IF W(I) = T 650 CONTINUE IF (WCOMP .LE. 2) GO TO 820 GO TO 999 C C *** PREGIBON ERRORS *** C 660 IF (WCOMP .GE. 2) CALL V7CPY(N, W, R) I = N + N + 3 IF (RHOI(4) .EQ. NF) GO TO 670 I = I + 3*N IF (RHOI(5) .EQ. NF) GO TO 670 WRITE(6,*) 'HELP! NF =', NF, ' BUT RHOI =', RHOI GO TO 800 670 IF (IM .EQ. 11) THEN CALL PREGRH(1, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) ELSE CALL PREGRV(1, F, N, NF, PT, R, RD, RHOI, YN(1,N+1), YN, 1 YN(1,I)) END IF IF (NF .EQ. 0) GO TO 999 GO TO (820,680,700,720), WCOMP 680 PSI = PT(3) T = (TWO - PT(2))*PSI - TWO T1 = PSI*PSI DO 690 I = 1, N 690 W(I) = YN(2,I) * T1 * W(I)**T GO TO 999 700 T = ONE / PT(3) DO 710 I = 1, N T1 = W(I) - ONE IF (T1 .NE. ZERO) THEN YI = YN(1,I) W(I) = R(I) / (W(I) - YI**T) ELSE W(I) = RD(I) END IF 710 CONTINUE GO TO 999 720 PHI = PT(1) THETA = PT(2) PSI = PT(3) IF (THETA .EQ. ONE) GO TO 740 IF (THETA .EQ. TWO) GO TO 760 T1 = ONE - THETA T2 = TWO - THETA PSI1 = PSI * T1 PSI2 = PSI * T2 DO 730 I = 1, N RI = W(I) YI = YN(1,I) T = YI**T2 E = YN(2,I)/PHI * ((T - YI*RI**PSI1)/T1 - (T - RI**PSI2)/T2) IF (E .NE. ZERO) THEN T = R(I) W(I) = T*T / (E+E) ELSE W(I) = RD(I) END IF 730 CONTINUE GO TO 999 740 DO 750 I = 1, N RI = W(I) YI = YN(1,I) T1 = YN(2,I)/PHI * (RI**PSI - YI + YI*(ALOG(YI)-PSI*ALOG(RI))) IF (T1 .NE. ZERO) THEN T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 750 CONTINUE GO TO 999 760 DO 770 I = 1, N RI = W(I) YI = YN(1,I) T1 = YI*RI**(-PSI) - ONE + PSI*ALOG(RI) - ALOG(YI) IF (T1 .NE. ZERO) THEN T1 = T1 * YN(2,I) / PHI T = R(I) W(I) = T*T / (T1+T1) ELSE W(I) = RD(I) END IF 770 CONTINUE GO TO 999 C C *** LEAST SQUARES *** C 780 DO 790 I = 1, N R(I) = R(I) - YN(1,I) RD(I) = ONE 790 CONTINUE GO TO 820 C 800 NF = 0 GO TO 999 C 810 IF (WCOMP .GT. 1) GO TO 999 820 CALL V7CPY(N, W, RD) C 999 RETURN END REAL FUNCTION LPN(X) COMMON /FUDGE/ NFUDGE INTEGER NFUDGE REAL X EXTERNAL PNORMS REAL PNORMS REAL T REAL ALOG REAL HALF, ZERO DATA HALF/0.5E+0/, ZERO/0.E+0/ C C *** BODY *** C T = PNORMS(X) IF (T .GT. ZERO) THEN LPN = ALOG(T) ELSE NFUDGE = NFUDGE + 1 LPN = -HALF*X**2 - ALOG(-X) END IF 999 RETURN END //GO.SYSIN DD spmain.f cat >smecdf.f <<'//GO.SYSIN DD smecdf.f' SUBROUTINE MECDF(NDIM, D, RHO, PROB, IER) INTEGER NDIM, IER REAL D(*), PROB, RHO(*) C----------------------------------------------------------------- C 6/29/90 C This subroutine is designed to calculate the MVN CDF C using the Mendell-Elston procedure as described in C Kamakura (1989). The current version is set up to go C as high as 19 dimensions (=> 20 MNP alternatives) C NOTE: Equation (15) in Kamakura has an error. C C Specifically, assume that Z is a set of random variables C with a standard normal distribution with correlations C stored in RHO (in packed form). Then this subroutine C calculates Prob[Z(1)>D(1);...; Z(NDIM) > D(NDIM)]. C----------------------------------------------------------------- REAL ALNORM, PHI EXTERNAL ALNORM, PHI INTEGER MAXALT, NMAX PARAMETER (MAXALT=20, NMAX=MAXALT-1) INTEGER I, IM1, IR, J, JM1, K, KM1 REAL PROBI, TMP REAL R(NMAX,NMAX,0:NMAX-1), SIG(NMAX,0:NMAX-1), 1 U(NMAX), UUMZ(NMAX-1), Z(NMAX,0:NMAX-1) REAL ONE, ZERO PARAMETER (ONE=1.E0, ZERO=0.E0) C----------------------------------------------------------------- C Test dimension IER = 0 IF (NDIM.GT.NMAX) THEN IER = -1 RETURN ENDIF C Set up arrays IR = 0 DO 10 I = 1, NDIM Z(I,0) = D(I) DO 10 J = 1, I-1 IR = IR + 1 R(J,I,0) = RHO(IR) 10 CONTINUE PROB = ALNORM(Z(1,0), .TRUE.) IF (PROB.LE.ZERO) THEN IER = 1 RETURN ENDIF U(1) = PHI(Z(1,0), ZERO)/PROB UUMZ(1) = U(1)*(U(1)-Z(1,0)) C Main loop DO 40 I = 2, NDIM IM1 = I-1 DO 30 J = 1, IM1 JM1 = J-1 DO 20 K = 1, JM1 KM1 = K-1 TMP = R(J,I,KM1)-R(K,J,KM1)*R(K,I,KM1)*UUMZ(K) R(J,I,K) = TMP/SIG(J,K)/SIG(I,K) 20 CONTINUE SIG(I,J) = SQRT(ONE - UUMZ(J)*R(J,I,JM1)**2) Z(I,J) = (Z(I,JM1)-U(J)*R(J,I,JM1))/SIG(I,J) 30 CONTINUE PROBI = ALNORM(Z(I,IM1), .TRUE.) IF (PROBI.LE.ZERO) THEN IER = I RETURN ENDIF PROB = PROB * PROBI IF (I.LT.NDIM) THEN U(I) = PHI(Z(I,IM1), ZERO)/PROBI UUMZ(I) = U(I)*(U(I)-Z(I,IM1)) ENDIF 40 CONTINUE END C--------------------------------------------------- REAL FUNCTION PHI(X, Y) REAL X, Y REAL ARG REAL HALF, SQ2P, XLOW, ZERO PARAMETER (HALF = 0.5E0, SQ2P = 0.91893853320467274E0, 1 XLOW = -87.E0, ZERO = 0.E0) PHI = ZERO ARG = -HALF * X * X - SQ2P - Y IF (ARG .GT. XLOW) PHI = EXP(ARG) END C--------------------------------------------------- REAL FUNCTION ALNORM(X,UPPER) REAL X LOGICAL UPPER C C ALGORITHM AS 66 BY I.D. HILL C LOGICAL UP REAL Y, Z REAL CON, HALF, LTONE, ONE, UTZERO, ZERO PARAMETER (CON=1.28E0, HALF=0.5E0, LTONE=5.E0, ONE=1.E0, 1 UTZERO=12.5E0, ZERO=0.E0) UP=UPPER Z=X IF(Z.GE.ZERO) GO TO 10 UP=.NOT.UP Z=-Z 10 IF(Z .LE. LTONE .OR. UP .AND. Z .LE. UTZERO) GO TO 20 ALNORM = ZERO GO TO 40 20 Y=HALF*Z*Z IF(Z.GT.CON) GO TO 30 ALNORM = HALF - Z * (0.398942280444E0 - 0.399903438504E0*Y/ 1 (Y + 5.75885480458E0 - 29.8213557808E0/ 2 (Y + 2.62433121679E0 + 48.6959930692E0/ 3 (Y + 5.92885724438E0)))) GO TO 40 30 ALNORM = 0.398942280385E0 * EXP(-Y)/ 1 (Z - 3.8052E-8 + 1.00000615302E0/ 2 (Z + 3.98064794E-4 + 1.98615381364E0/ 3 (Z - 0.151679116635E0 + 5.29330324926E0/ 4 (Z + 4.8385912808E0 - 15.1508972451E0/ 5 (Z + 0.742380924027E0 + 30.789933034E0/ 6 (Z + 3.99019417011E0)))))) 40 IF(.NOT.UP) ALNORM = ONE - ALNORM END //GO.SYSIN DD smecdf.f cat >smlmnp.f <<'//GO.SYSIN DD smlmnp.f' PROGRAM MLMNP C C VERSION: SEPTEMBER 4, 1991 C C *** MAXIMUM LIKELIHOOD ESTIMATION OF THE LINEAR-IN-PARAMETERS *** C *** MULTINOMIAL PROBIT MODEL (VIA MENDELL-ELSTON PROBABILITIES). *** C *** SEE REFERENCES BELOW. *** C C *** THIS VERSION DOES NOT IMPOSE SIMPLE BOUNDS ON THE PARAMETERS.*** C *** THIS VERSION DOES CALCULATE T-SCORES AND REGRESSION *** C *** DIAGNOSTICS. *** C C *** THIS PROGRAM UTILIZES A GENERAL FRAMEWORK FOR MLE OF A *** C *** PROBABILISTIC CHOICE MODEL AND MAY BE MODIFIED FOR USE WITH *** C *** OTHER CHOICE MODELS. (SEE "PROTOTYE PROGRAM" DISCUSSION.) *** C C PROGRAM MLEPCM ("PROTOTYPE PROGRAM") C *** MAXIMUM LIKELIHOOD ESTIMATION OF PROBABILISTIC CHOICE MODELS *** C C *** DESCRIPTION *** C C THIS PROGRAM PERFORMS MAXIMUM LIKELIHOOD ESTIMATION BY MINIMIZING C THE NEGATIVE OF THE LOG-LIKELIHOOD FUNCTION. THE FUNCTION IS WRITTEN C AS C C -SUM{FOR I=1, NOBS} WT(I)*LOG P[ICH(I), IX(I), RX(I)] C C WHERE: C P[ICH(I), IX(I), RX(I)] IS A GENERAL PROBABILISTIC CHOICE MODEL, C ICH(I) IS THE CHOICE MADE FOR OBSERVATION I, C IX(I) CONTAINS INTEGER EXPLANATORY DATA SPECIFIC TO OBSERVATION I C (E.G., A LIST OF ALTERNATIVES IN THE CHOICE SET), C RX(I) CONTAINS REAL EXPLANATORY DATA SPECIFIC TO OBSERVATION I, C AND WT(I) IS A WEIGHT FOR OBSERVATION I. C C THIS PROGRAM IS DESIGNED TO CALL THE GENERALIZED REGRESSION C OPTIMIZATION SUBROUTINES GLG AND GLGB, WHICH IN TURN CALL RGLG C AND RGLGB, ETC. A FEW LEVELS DOWN, THE PROBABILITY C P[ICH(I), IX(I), RX(I)] IS COMPUTED IN A USER-SUPPLIED SUBROUTINE C CALCPR, USING THE FOLLOWING CALL: C C CALL CALCPR(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, C 1 PROB, IUSER, RUSER, MNPCDF) C C FOR A DESCRIPTION OF PARAMETER USAGE, SEE THE SUBROUTINE. C C *** MLEPCM PARAMETER DECLARATIONS *** C C SCALARS: C INTEGER BS, COVTYP, ICSET, IDR, IOUNIT, NB, NFIX, NIUSER INTEGER NIVAR, NOBS, NPAR, NRUSER, NRVAR, WEIGHT, XNOTI C C ARRAYS: C INTEGER IV(300), RHOI(28000), UI(24000) REAL B(2,60), RHOR(164000), UR(160000), V(268105) REAL X(60) REAL TSTAT(60), STDERR(60) EQUIVALENCE (RHOI(1), UI(1)), (RHOR(1), UR(1)) CHARACTER*8 VNAME(60) C C LENGTHS OF ARRAYS: C INTEGER LIV, LRHOI, LRHOR, LUI, LUR, LV, LX C C INTEGER IV(LIV), RHOI(LRHOI), UI(LUI) C REAL B(2,LX), RHOR(LRHOR), UR(LUR), V(LV), X(LX) C C SUBROUTINES: C REAL R7MDC EXTERNAL GLG, IVSET, R7MDC, FPRINT, MECDF, PCMRHO, PCMRJ C C *** MLEPCM PARAMETER USAGE *** C C (SEE EXPLANATIONS BELOW) C C SCALARS: C C BS...... BLOCK-SIZE, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS ARE C REQUESTED AND ALL BLOCKS ARE THE SAME SIZE (SEE BELOW). C COVTYP.. INDICATES TYPE OF VARIANCE-COVARIANCE MATRIX APPROXIMATION. C = 1 FOR H^-1, WHERE H IS THE FINITE-DIFFERENCE HESSIAN C AT THE SOLUTION. C = 2 FOR (J^T J)^-1, I.E., THE GAUSS-NEWTON HESSIAN C APPROXIMATION AT THE SOLUTION. C ICSET... INDICATOR OF FIXED- OR VARIABLE-SIZE CHOICE SETS. C IDR..... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C IOUNIT.. OUTPUT UNIT NUMBER FOR PRINTING ERROR MESSAGES. C = FORTRAN UNIT FOR IOUNIT > 0. DEFAULT = 6. C IPRNT... INDEX INDICATING PRINT OPTIONS. C = 0 FOR NO ADDITIONAL PRINTING. C = 1 FOR FINAL CHOICE PROBABILITIES. C (DEFAULT = 0.) C NB...... NUMBER OF BLOCKS, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS C ARE REQUESTED (SEE BELOW). C NFIX.... PARAMETER USED BY RGLG. NFIX = 0. C NIVAR... NUMBER OF (INTEGER) DATA VARIABLES PER CHOICE SET. C NIUSER.. NUMBER OF (INTEGER) USER-SPECIFIED CONSTANTS. C NOBS.... NUMBER OF OBSERVATIONS. C NPAR.... NUMBER OF MODEL PARAMETERS (X COMPONENTS). C NRVAR... NUMBER OF (REAL) DATA VARIABLES PER CHOICE SET. C NRUSER.. NUMBER OF (REAL) USER-SPECIFIED CONSTANTS. C WEIGHT.. INDICATOR FOR USER-PROVIDED WEIGHTS. C XNOTI... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C C ARRAYS AND ARRAY LENGTHS: C C B....... REAL ARRAY OF UPPER AND LOWER BOUNDS ON PARAMETER VALUES. C IV...... INTEGER VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C LIV..... LENGTH OF IV; MUST BE AT LEAST 90 + NPAR. C CURRENT LIV = 300. C LV...... LENGTH OF LV; MUST BE AT LEAST C 105 + P*(3*P + 16) + 2*N + 4P + N*(P + 2), WHERE C P = NPAR AND N = NOBS. FOR P = 60 AND N = 4000, THIS C EXPRESSION GIVES 268105. CURRENT LV = 268105. C LRHOI... LENGTH OF RHOI. CURRENT LRHOI = LUI + 4000 = 28000. C LRHOR... LENGTH OF RHOR. CURRENT LRHOR = LUR + 4000 = 164000. C LUI..... LENGTH OF UI. CURRENT LUI = 24000. C LUR..... LENGHT OF UR. CURRENT LUR = 160000. C LX...... LENGTH OF PARAMETER VECTOR X. CURRENT LX = 30. C RHOI.... INTEGER VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO PASS BLOCK-SIZES IF LEAVE-BLOCK-OUT C REGRESSION DIAGNOSTICS WITH VARIABLE BLOCK-SIZES ARE C REQUESTED (SEE BELOW). (CURRENT PCMRHO MAKES USE OF C RHOI THROUGH EQUIVALENCE OF RHOI WITH UI.) C RHOR.... REAL VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO STORE X(I) VECTORS, IF SUCH REGRESSION C DIAGNOSTICS ARE REQUESTED (SEE BELOW). (CURRENT PCMRHO C MAKES USE OF RHOR THROUGH 2EQUIVALENCE OF RHOR WITH UR.) C UI...... INTEGER VALUE ARRAY FOR USER STORAGE (SEE BELOW). C UI(1) TO UI(10) STORE MLEPCM PARAMETERS FOR USE IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C UR...... REAL VALUE ARRAY FOR USER STORAGE (SEE BELOW). C V....... REAL VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C VNAME... ARRAY OF PARAMETER NAMES FOR X COMPONENTS BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED. C C SUBROUTINES: C C PCMRJ... SUBROUTINE THAT CALCULATES GENERALIZED RESIDUAL VECTOR, C AND THE JACOBIAN OF THE GENERALIZED RESIDUAL VECTOR. C SEE DISCUSSION OF "CALCRJ" IN GLG. C PCMRHO.. SUBROUTINE THAT CALCULATES THE CRITERION FUNCTION, AND C ITS DERIVATIVES. SEE DISCUSSION OF "RHO" IN RGLG. C MECDF... SUBROUTINE THAT CALCULATES THE MULTIVARIATE NORMAL CDF C USING THE FIXED-ORDER MENDELL-ELSTON APPROXIMATION. C PASSED WITHOUT CHANGE TO CALCPR. (COULD BE REPLACED C WITH ANOTHER CDF ROUTINE IF DESIRED.) C C C *** DISCUSSION FOR MLEPCM *** C C *** DATA INPUT STREAM *** C C *** GENERAL PARAMETERS ARE READ IN FIRST FROM "INPUT BLOCK 1": *** C C READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT,COVTYP,IDR C C THESE PARAMETERS ARE INTENDED TO GIVE A FLEXIBLE INPUT C FORMAT FOR CHOICE MODELS, WITH SOME SHORTCUTS FOR SIMPLE CASES. C SPECIFIC SETTINGS OF THE ABOVE PARAMETERS WILL PRODUCE DIFFERENCES C IN THE INPUT STREAM FORMAT. C C FOR ICSET = 0 (OR 1) A VARIABLE NUMBER OF ALTERNATIVES PER CHOICE C SET IS USED. THE USER MUST PROVIDE THIS NUMBER FOR EACH C OBSERVATION. C FOR ICSET > 1 EACH CHOICE SET IS ASSUMED TO INCLUDE ICSET C ALTERNATIVES. C C WEIGHT = 1 MEANS THAT EACH OBSERVATION REQUIRES A WEIGHT, WHICH C MUST BE PROVIDED BY THE USER. C WEIGHT = 0 MEANS THAT ALL OBSERVATIONS AUTOMATICALLY RECEIVE EQUAL C WEIGHT AND THEREFORE NO USER-SUPPLIED WEIGHTS ARE REQUIRED. C C FOR NIVAR = -1 NO INTEGER DATA VALUES ARE REQUIRED BY THE MODEL. C FOR NIVAR = 0 A VARIABLE NUMBER OF INTEGER DATA VALUES IS STORED C PER OBSERVATION. IN THIS CASE, THE USER MUST INCLUDE FOR EACH C OBSERVATION THE NUMBER OF INTEGER VALUES TO BE STORED FOLLOWED C BY THE INTEGER VALUES THEMSELVES. (THIS MIGHT BE USED IN C CONJUNCTION WITH ICSET=0 TO LIST NOMINAL VARIABLES FOR THE C CHOICE ALTERNATIVES IN THE CHOICE SET.) C FOR NIVAR > 0 EACH OBSERVATION IS ASSUMED TO INCLUDE NIVAR INTEGERS. C C FOR NRVAR THE USAGE IS ANALOGOUS TO NIVAR, ONLY FOR REAL DATA. C C NIUSER AND NRUSER ARE USED TO INDICATE THE NUMBER OF CONSTANTS C TO BE PASSED TO THE MODEL SUBROUTINES. THESE ARE MODEL SPECIFIC. C FOR SOME CODES NIUSER, NRUSER, AND PERHAPS THE CONSTANTS, MIGHT C BE SET IN THE MAIN PROGRAM AND NOT BY THE INPUT STREAM. C C FOR MORE DETAILS ON THIS, SEE THE ACTUAL CODE BELOW. C C IN ADDITION TO DATA STORAGE, MLEPCM PROVIDES A RATHER FLEXIBLE C CHOICE OF STATISTICAL ANALYSES. IN THE VERSION OF THE PROGRAM C WHICH ENFORCES BOUNDS, STATISTICS ARE NOT CALCULATED. HOWEVER, C FOR CONVENIENCE IT IS ASSUMED THAT THE SAME INPUT STREAM IS USED C FOR BOTH PROGRAMS. C C TO CALCULATE ASYMPTOTIC T-SCORES, A VARIANCE-COVARIANCE MATRIX C APPROXIMATION IS REQUIRED. SEE COVTYP ABOVE. C C TO PERFORM REGRESSION DIAGNOSTICS, THE FOLLOWING PARAMETERS C ARE USED: C C IDR = 0 IF NO REGRESSION DIAGNOSTICS ARE DESIRED. C C = 1 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)), WHERE X(I) C MINIMIZES F (THE NEGATIVE LOG-LIKELIHOOD) WITH C OBSERVATION I REMOVED, AND X* IS THE MLE FOR THE FULL C DATASET. ("LEAVE-ONE-OUT" DIAGNOSTICS.) C C = 2 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)) AS WHEN IDR = 1, C AND ALSO THE ONE-STEP ESTIMATES OF X(I), I = 1 TO NOBS. C C = 3 FOR "LEAVE-BLOCK-OUT" DIAGNOSTICS. (DISCUSSION FOLLOWS.) C C *** PARAMETERS RELATED TO "LEAVE-BLOCK-OUT" REGRESSION DIAGNOSTICS *** C *** READ NEXT FROM "INPUT BLOCK 2" (IF APPLICABLE). *** C C "LEAVE-BLOCK-OUT" DIAGNOSTICS C C IN THIS CASE, ONE OR MORE ADDITIONAL LINES OF DATA ARE C REQUIRED. IF IDR = 3, THE FOLLOWING STATEMENT IS EXECUTED: C C READ(1,*) BS, NB, XNOTI C C NB = NUMBER OF BLOCKS C C XNOTI = 0 IF NO X(I) DIAGNOSTICS ARE REQUESTED, C = 1 OTHERWISE. C C BS > 0 MEANS THAT FIXED BLOCK SIZES OF SIZE BS ARE USED. C IN THIS CASE NB * BS = NOBS, AND THE PROGRAM C PROCEEDS TO "INPUT BLOCK 3" FOR MNP INPUT PARAMETERS. C C BS = 0 MEANS THAT VARIABLE BLOCK SIZES ARE USED. C IN THIS CASE THE NEXT FORMAT STATEMENT READS C THE BLOCK SIZES INTO RHOI USING FREE FORMAT: C C LR1 = LUI + 1 C LR2 = LR1 + NB C READ(1,*) (RHOI(I),I=LR1,LR2) C C *** THE PROGRAM THEN PROCEEDS TO "INPUT BLOCK 3" TO READ MODEL-*** C *** RELATED PARAMETERS. SEE DISCUSSION FOR MNP MODEL BELOW. *** C C *** INPUT BLOCK 4 CONTAINS THE INITIAL GUESS FOR THE SEARCH. *** C *** IT INCLUDES VARIABLE NAMES, A STARTING GUESS, AND BOUNDS. *** C C DO 10 I = 1, NPAR C READ(1,3) VNAME(I) C 3 FORMAT(1X,A8) C READ(1,*) X(I), B(1,I), B(2,I) C WRITE(IOUNIT,4) I, VNAME(I),X(I), B(1,I), B(2,I) C 4 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) C 10 CONTINUE C CLOSE(1) C C *** FOR THE LINEAR-IN-PARAMETERS MNP MODEL, THE ORDERING OF *** C *** PARAMETERS IS AS FOLLOWS: *** C C 1. MEAN TASTE WEIGHTS FOR GENERIC ATTRIBUTES (NATTR OF THESE). C 2. ALTERNATIVE-SPECIFIC MEANS (NALT-1 OF THESE). C 3. COVARIANCE PARAMETERS FOR ALTERNATIVE-SPECIFIC ERRORS. C THERE ARE 2(NALT-1)(NALT)/2 - 1 OF THESE, IN THE FORM OF C CHOLESKY DECOMPOSITION, STORED ROW-WISE: C B21 B22 C B31 B32 B33 C B(J-1,1) B(J-1,2) ..........B(J-1,J-1) C WHERE B11 = SCALE IS ASSUMED. C SEE BUNCH(1991, TRANSP. RES. B, VOL. 1, PP. 1-12); NOTE C THE MISPRINT IN EQUATION (26). C (NOTE THAT PARAMETERS ARE READ IN ONE PARAMETER PER LINE.) C 4. COVARIANCE PARAMETERS FOR TASTE VARIATION. C NATTR VARIANCES IF ITASTE=1 (UNCORRELATED). C NATTR*(NATTR+1)/2 CHOLESKY PARAMETERS IF ITASTE=2 C (I.E., CORRELATED). C C *** UNIT 1 IS CLOSED, AND THE MODEL DATA IS READ FROM UNIT 2. *** C *** ITS FORMAT IS CONTROLLED BY THE GENERAL PARAMETERS ABOVE. *** C *** FOR THE SPECIFIC FREE-FORMAT READ STATEMENTS, SEE THE MAIN *** C *** BODY OF THE CODE. *** C C C *** MULTINOMIAL PROBIT MODEL PARAMETERS *** C (PARAMETERS SPECIFIC TO THIS MODEL IMPLEMENTATION) C INTEGER ICOV, IDUM, ITASTE, NALT, NATTR INTEGER IUSER(18) EQUIVALENCE (UI(11),IUSER(1)) C C *** PARAMETER USAGE *** C C THE FOLLOWING ARE USER-PROVIDED INTEGER CONSTANTS: C C IDUM.... INDICATOR FOR ALTERNATIVE-SPECIFIC DUMMIES, C = 0 FOR NO, = 1 FOR YES. IF ICSET .NE. 0, THEN C THE SAME SET OF DUMMIES IS USED FOR EACH CHOICE SET. C OTHERWISE, INTEGER DATA SHOULD BE USED TO IDENTIFY THE C ALTERNATIVES IN EACH CHOICE SET (SEE NALT BELOW). C ICOV.... INDICATOR FOR TYPE OF ALTERNATIVE-SPECIFIC ERRORS, C = 0 FOR IID ERRORS, = 1 FOR CORRELATED ERRORS. C IF ICSET .NE. 0, THEN THE SAME CORRELATION MATRIX IS C USED FOR EVERY SUBSET. OTHERWISE, INTEGER DATA SHOULD C BE USED TO IDENTIFY THE ALTERNATIVES IN EACH CHOICE SET. C ITASTE.. INDICATOR FOR TASTE VARIATION, C = 0 FOR NO TASTE VARIATION, = 1 FOR UNCORRELATED TASTE C VARIATION, = 2 FOR CORRELATED TASTE VARIATION. C IUSER... INTEGER ARRAY THAT STORES MNP MODEL PARAMETERS USED IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C NALT.... TOTAL NUMBER OF NOMINAL CHOICE ALTERNATIVES (IF APPLICABLE). C IF ICSET .NE. 0, THEN NALT IS SET EQUAL TO ICSET. C OTHERWISE, NALT SHOULD BE > 0 IF EITHER IDUM OR ICOV C (OR BOTH) ARE > 0. C NATTR... NUMBER OF ATTRIBUTES (I.E., REAL DATA VARS.) PER C ALTERNATIVE. C C C *** READ STATEMENT FOR INPUT BLOCK 3 *** C C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER I, ICH, ICHECK, ICP, IETA0, IH, II, IICDAT, IICH, IIIV, 1 IIRV, IIU, INALT, IOBS, IPCOEF, IPCOV, IPDUM, IPRNT, 2 IPTAST, IRCDAT, IRU, IRW, ISCALE, ISIGP, ISIGU, ITST, 3 IV85, IV86, IV87, IV90, K, LCOVP, LCOVU, LCOVX, LOO, 4 LRI1, LRR1, LW, NBSCHK, NF, NPCHK, NPS, 5 NRICHK, NRRCHK, RDR REAL MKTSHR(20) REAL RFI, RHOSQR, RSQHAT, RLL0, RLLC, RLLR, RNI, 1 RNOBS C REAL ETA0, ONE, SCALE, TWO, ZERO C DATA ZERO/0.E0/ DATA ONE/1.E0/ DATA TWO/2.E0/ C C *** GENERAL *** C C CODED BY DAVID S. BUNCH C SUPPORTED BY U.S. DEPARTMENT OF TRANSPORTATION THROUGH C REGION NINE TRANSPORTATION CENTER AT UNIVERSITY OF CALIFORNIA, C BERKELEY (WINTER-SUMMER 1991) C--------------------------------- BODY ------------------------------ C C *** INITIALIZE SOME PARAMETERS *** C (SEE DISCUSSION ABOVE) NFIX = 0 LIV = 300 LRI1 = 24001 LRHOI = 28000 LRHOR = 164000 LRR1 = 160001 LV = 268105 LUI = 24000 LUR = 160000 LX = 60 C C *** READ MLEPCM PARAMETERS FROM INPUT BLOCK 1 *** C OPEN(1,FILE='fort.1') REWIND 1 OPEN(2,FILE='fort.2') REWIND 2 READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT, 1 COVTYP,IDR C IF (IOUNIT.LE.0) THEN IOUNIT = 6 WRITE(IOUNIT,10) 10 FORMAT(/' *** INVALID IOUNIT SET EQUAL TO 6 ***',//) ENDIF C WRITE(IOUNIT,20) 20 FORMAT(' PROGRAM MLMNP',//,' MAXIMUM LIKELIHOOD ESTIMATION OF', 1 /,' LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS',/, 1 ' (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED)',//) WRITE(IOUNIT,30) NOBS 30 FORMAT(' NUMBER OF OBSERVATIONS.................',I4) IF (ICSET.EQ.1) ICSET = 0 IF (ICSET.EQ.0) THEN WRITE(IOUNIT,40) 40 FORMAT(' FLEXIBLE CHOICE SETS USED') ELSE WRITE(IOUNIT,50) ICSET 50 FORMAT(' NUMBER OF ALTERNATIVES PER CHOICE SET..',I4) ENDIF IF (WEIGHT.EQ.1) THEN WRITE(IOUNIT,60) 60 FORMAT(' USER-PROVIDED WEIGHTS USED') ELSE WRITE(IOUNIT,70) 70 FORMAT(' EQUAL WEIGHTS FOR ALL OBSERVATIONS') ENDIF IF (NIVAR.EQ.-1) THEN WRITE(IOUNIT,80) 80 FORMAT(' NO INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.EQ.0) THEN WRITE(IOUNIT,90) 90 FORMAT(' FLEXIBLE INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.GT.0) THEN WRITE(IOUNIT,100) NIVAR 100 FORMAT(' NUMBER OF INTEGER DATA VALUES PER OBS..',I4) ENDIF IF (NRVAR.EQ.-1) THEN WRITE(IOUNIT,110) 110 FORMAT(' NO REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.EQ.0) THEN WRITE(IOUNIT,120) 120 FORMAT(' FLEXIBLE REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.GT.0) THEN WRITE(IOUNIT,130) NRVAR 130 FORMAT(' NUMBER OF REAL DATA VALUES PER OBS.....',I4) ENDIF WRITE(IOUNIT,140) IOUNIT 140 FORMAT(' OUTPUT UNIT............................',I4,/) IF ((COVTYP.NE.1).AND.(COVTYP.NE.2)) THEN COVTYP = 1 WRITE(IOUNIT,150) 150 FORMAT(' *** INVALID COVTYP SET TO 1 ***',/) ENDIF IF (COVTYP.EQ.1) WRITE(IOUNIT,160) 160 FORMAT(' COVARIANCE TYPE = INVERSE FINITE-DIFFERENCE HESSIAN') IF (COVTYP.EQ.2) WRITE(IOUNIT,170) 170 FORMAT(' COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN') IF ((IDR.LT.0).OR.(IDR.GT.3)) THEN IDR = 0 WRITE(IOUNIT,180) 180 FORMAT(/,' *** INVALID IDR SET TO 0 ***',/) ENDIF IF (IDR.EQ.0) WRITE(IOUNIT,190) 190 FORMAT(' NO REGRESSION DIAGNOSTICS REQUESTED') IF (IDR.GE.1) WRITE(IOUNIT,200) 200 FORMAT(' REGRESSION DIAGNOSTICS REQUESTED') IF ((IDR.EQ.1).OR.(IDR.EQ.2)) WRITE(IOUNIT,210) 210 FORMAT(' STANDARD LEAVE-ONE-OUT DIAGNOSTICS REQUESTED') IF (IDR.EQ.2) WRITE(IOUNIT,220) 220 FORMAT(' DIAGNOSTICS ON X-VECTOR REQUESTED') IF (IDR.EQ.3) WRITE(IOUNIT,230) 230 FORMAT(/,' *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED ***') WRITE(IOUNIT,*) C C *** PROCESS REGRESSION DIAGNOSTICS *** C IF (IDR.EQ.0) RDR = 0 C IF (IDR.EQ.1) THEN RDR = 1 LOO = 0 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = 0 IV90 = 0 NRICHK = LUI + 1 NRRCHK = 0 ENDIF C IF (IDR.EQ.2) THEN RDR = 2 LOO = 1 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = NOBS IV90 = LRR1 NRICHK = LUI + NOBS NRRCHK = LUR + NOBS * NPAR ENDIF C C *** INPUT FOR SPECIAL REGRESSION DIAGNOSTICS *** C *** BEGIN READING "INPUT BLOCK 2" *** C IF (IDR.EQ.3) THEN READ(1,*) BS, NB, XNOTI C IF (BS.LT.0) THEN BS = 0 WRITE(IOUNIT,240) 240 FORMAT(/,' *** NEGATIVE BLOCK-SIZE (BS) SET TO 0 ***',/) ENDIF C IF (NB.LE.0) THEN WRITE(IOUNIT,250) 250 FORMAT(/,' *** INVALID NO. OF BLOCKS (NB). STOP. ***',/) STOP ENDIF C IF ((XNOTI.NE.0).AND.(XNOTI.NE.1)) THEN XNOTI = 0 WRITE(IOUNIT,260) 260 FORMAT(/,' *** INVALID XNOTI SET TO 0. ***',/) ENDIF IF (XNOTI.EQ.1) WRITE(IOUNIT,220) WRITE(IOUNIT,270) NB 270 FORMAT(' NUMBER OF BLOCKS: ',I4) C RDR = 2 LOO = 2 IV85 = LRI1 IV86 = 0 IV87 = NB IF (XNOTI.EQ.1) THEN IV90 = LRR1 NRRCHK = LUR + NB * NPAR ENDIF C IF (BS.GT.0) THEN WRITE(IOUNIT,280) BS 280 FORMAT(' FIXED BLOCK SIZE: ',I4,/) IF (BS*NB.NE.NOBS) THEN WRITE(IOUNIT,290) 290 FORMAT(/,' *** (BS * NB) .NE. NOBS. STOP. ***',/) STOP ENDIF RHOI(LRI1) = BS NRICHK = LUI + 1 ELSE IV86 = 1 WRITE(IOUNIT,300) 300 FORMAT(' VARIABLE BLOCK-SIZE OPTION CHOSEN',/) NRICHK = LUI + NB ENDIF ENDIF C C *** CHECK SIZE OF RHOI *** IF (NRICHK.GT.LRHOI) THEN WRITE(IOUNIT,310) 310 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C *** IF VARIABLE-LENGTH BLOCKSIZES ARE USED, *** C *** READ THEM IN AND TEST THEM. *** C IF (IV86.EQ.1) THEN READ(1,*) (RHOI(I),I=LRI1,NRICHK) WRITE(IOUNIT,320) 320 FORMAT(' BLOCK-SIZES: ') WRITE(IOUNIT,330) (RHOI(I),I=LRI1,NRICHK) 330 FORMAT(5X,15I5) WRITE(IOUNIT,*) ICHECK = 0 DO 350 I = LRI1, NRICHK IF (RHOI(I).LE.0) THEN ICHECK = 1 WRITE(IOUNIT,340) I-LUI 340 FORMAT(' *** BLOCK-SIZE ',I5,' IS INVALID ***') ENDIF NBSCHK = NBSCHK + RHOI(I) 350 CONTINUE IF (ICHECK.EQ.1) THEN WRITE(IOUNIT,360) 360 FORMAT(/,' *** CANNOT PROCEED WITH INVALID BLOCK-SIZES. ', 1 'STOP. ***') STOP ENDIF IF (NBSCHK.NE.NOBS) THEN WRITE(IOUNIT,370) 370 FORMAT(/,' *** SUM OF BLOCK-SIZES .NE. NOBS. STOP. ***') STOP ENDIF ENDIF C C *** CHECK SIZE OF RHOR *** IF (NRRCHK.GT.LRHOR) THEN WRITE(IOUNIT,380) 380 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C C *** READ MNP PARAMETERS FROM INPUT BLOCK 3 *** C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C IF (ICSET.NE.0) THEN IF ((NALT.NE.0).AND.(NALT.NE.ICSET)) THEN WRITE(IOUNIT,390) 390 FORMAT(' *** NOTE: ERROR IN NALT OR ICSET ***') STOP ENDIF NALT = ICSET WRITE(IOUNIT,400) 400 FORMAT(' *** NOTE: NALT SET EQUAL TO ICSET ***') ENDIF IF (NALT.EQ.0) THEN WRITE(IOUNIT,410) 410 FORMAT(' NO NOMINAL VARIABLES') ELSE WRITE(IOUNIT,420) NALT 420 FORMAT(' NUMBER OF NOMINAL VARIABLES............',I4) ENDIF C WRITE(IOUNIT,430) NATTR 430 FORMAT(' NUMBER OF ATTRIBUTES PER ALTERNATIVE...',I4) IF (IDUM.EQ.0) THEN WRITE(IOUNIT,440) 440 FORMAT(' NO NOMINAL DUMMIES') ELSE WRITE(IOUNIT,450) 450 FORMAT(' NOMINAL DUMMIES USED') ENDIF IF (ICOV.EQ.0) THEN WRITE(IOUNIT,460) 460 FORMAT(' IID ERROR TERMS') ELSE WRITE(IOUNIT,470) 470 FORMAT(' CORRELATED ERROR TERMS') ENDIF IF (ITASTE.EQ.0) THEN WRITE(IOUNIT,480) 480 FORMAT(' NO RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.1) THEN WRITE(IOUNIT,490) 490 FORMAT(' UNCORRELATED RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.2) THEN WRITE(IOUNIT,500) 500 FORMAT(' CORRELATED RANDOM TASTE VARIATION') ENDIF C WRITE(IOUNIT,510) NPAR 510 FORMAT(/,' NUMBER OF MODEL PARAMETERS.............',I4,/) C C *** CHECK INITIAL DATA *** C (ADD MORE ERROR CHECKING HERE?) C IF (((IDUM.NE.0).OR.(ICOV.NE.0)).AND.(NALT.EQ.0)) THEN WRITE(IOUNIT,520) 520 FORMAT(' *** ERROR WITH IDUM OR ICOV OR NALT OR ICSET ***') STOP ENDIF C C *** CHECK NPAR *** C NPCHK = NATTR IF (IDUM.EQ.1) NPCHK = NPCHK + NALT - 1 LCOVX = 0 LCOVP = 0 LCOVU = 0 IF (ICOV.EQ.1) THEN LCOVX = NALT*(NALT-1)/2 - 1 NPCHK = NPCHK + LCOVX LCOVP = NALT*(NALT+1)/2 LCOVU = NALT*NALT ENDIF IF (ITASTE.EQ.1) NPCHK = NPCHK + NATTR IF (ITASTE.EQ.2) NPCHK = NPCHK + NATTR*(NATTR+1)/2 IF (NPAR.NE.NPCHK) THEN WRITE(IOUNIT,*) ' NPCHK = ',NPCHK WRITE(IOUNIT,*) ' INCORRECT NUMBER OF MODEL PARAMETERS' STOP ENDIF C C *** READ INITIAL PARAMETER ESTIMATES FROM UNIT 1 *** C WRITE(IOUNIT,530) 530 FORMAT(' INITIAL PARAMETER VECTOR AND BOUNDS: ') DO 560 I = 1, NPAR READ(1,540) VNAME(I) 540 FORMAT(1X,A8) READ(1,*) X(I), B(1,I), B(2,I) WRITE(IOUNIT,550) I, VNAME(I),X(I), B(1,I), B(2,I) 550 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) 560 CONTINUE CLOSE(1) C C *** SET UP UI STORAGE POINTERS (FOR MLEPCM) *** C C NIUSER AND NRUSER ARE USED TO RESERVE STORAGE FOR THE USER. C NIUSER AND NRUSER FOR MNP APPLICATION: C NIUSER = 18 LW = MAX(NATTR * NALT, LCOVP) NRUSER = LW + LCOVU + 2 C C (SEE HOW UI AND UR ARE USED BELOW TO PASS MNP INFORMATION) C C MLEPCM ARRAY POINTERS FOR UI: IIU = 11 IICH = NIUSER + IIU INALT = IICH + NOBS IIIV = INALT + NOBS IIRV = IIIV + NOBS IICDAT = IIRV + NOBS C C MLEPCM ARRAY POINTERS FOR UR: IRU = 1 ICP = IRU + NRUSER IRW = ICP + 2*NOBS IRCDAT = IRW + NOBS C C MLEPCM STORES POINTERS IN UI(1) THROUGH UI(10): UI(1) = IIU UI(2) = IICH UI(3) = INALT UI(4) = IIIV UI(5) = IIRV UI(6) = IICDAT UI(7) = IRU UI(8) = ICP UI(9) = IRW UI(10) = IRCDAT C C *** STORE MNP MODEL CONSTANTS STARTING IN IUSER(1) (=UI(11)) *** C C STORAGE FOR PASSING INVOCATION COUNTS: C UI(11) = NF1 = IUSER(1) C UI(12) = NF2 = IUSER(2) C C BASIC MNP MODEL INFORMATION: IUSER(3) = IOUNIT IUSER(4) = WEIGHT IUSER(5) = ICSET IUSER(6) = NALT IUSER(7) = NATTR IUSER(8) = IDUM IUSER(9) = ICOV IUSER(10) = ITASTE C C X ARRAY POINTERS (POINT TO START POSITION - 1): II = 0 IF (NATTR.NE.0) THEN IPCOEF = II II = II + NATTR ENDIF IF (IDUM.NE.0) THEN IPDUM = II II = II + NALT - 1 ENDIF IF (ICOV.NE.0) THEN IPCOV = II II = II + LCOVX ENDIF IF (ITASTE.NE.0) IPTAST = II C IUSER(11) = IPCOEF IUSER(12) = IPDUM IUSER(13) = IPCOV IUSER(14) = IPTAST C C ETA0 POINTER: IETA0 = 1 IUSER(17) = IETA0 C C SCALE POINTER: ISCALE = 2 IUSER(18) = ISCALE C C SIGMA (AND W) POINTERS: ISIGP = 3 C IW = ISIGP (W AND SIGP SHARE THE SAME STORAGE) ISIGU = ISIGP + LW C IUSER(15) = ISIGP IUSER(16) = ISIGU C C *** SET UP RUSER INFORMATION FOR MNP MODEL USE *** C C SET ETA0 EQUAL TO MACHEP C (ETA0 IS USED BY FINITE-DIFFERENCE ROUTINE S7GRD.) ETA0 = R7MDC(3) UR(IETA0) = ETA0 C C (SCALE SETS THE SCALING OF THE PROBIT MODEL COVARIANCE MATRIX) SCALE = ONE UR(ISCALE) = SCALE C C *** READ THE REST OF THE DATA FROM UNIT 1 (GENERAL TO MLEPCM ) *** C *** STORE IT IN THE APPROPRIATE UI AND UR LOCATIONS *** C IICDAT = IICDAT - 1 IRCDAT = IRCDAT - 1 DO 640 IOBS = 1, NOBS IF (ICSET.EQ.0) THEN READ(2,*) UI(IICH), UI(INALT) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH 570 FORMAT(1X,' CHOICE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE INDEX: ',/,5X,I3) WRITE(IOUNIT,580) 580 FORMAT(' *** PROGRAM TERMINATED... ***') STOP ENDIF ITST = UI(INALT) IF ((ITST.LE.1).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,590) IOBS,ITST 590 FORMAT(1X,' CHOICE SET SIZE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE SET SIZE: ',/,5X,I3) WRITE(IOUNIT,580) STOP ENDIF ELSE READ(2,*) UI(IICH) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH WRITE(IOUNIT,580) STOP ENDIF UI(INALT) = ICSET ENDIF C IF (NIVAR.EQ.0) THEN READ(2,*) UI(IIIV), (UI(IICDAT+K),K=1,UI(IIIV)) ENDIF IF (NIVAR.GT.0) THEN READ(2,*) (UI(IICDAT+K),K=1,NIVAR) UI(IIIV) = NIVAR ENDIF C C *** MNP CODE: CHECK INTEGER VALUES FOR CORRECTNESS *** C IF (NIVAR.GE.0) THEN DO 610 I = 1, UI(IIIV) ITST = UI(IICDAT+I) IF ((ITST.LE.0).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,600) IOBS,(UI(IICDAT+K),K=1,UI(IIIV)) 600 FORMAT(1X,' CHOICE SET INDEX ERROR IN OBS. NO. ', 1 I4,/,1X,' INTEGER VALUES: ',/,5X,20I3) WRITE(IOUNIT,580) STOP ENDIF 610 CONTINUE IICDAT = IICDAT + UI(IIIV) ENDIF C IF (IICDAT.GT.LUI) THEN WRITE(IOUNIT,620) 620 FORMAT(/,' *** STORAGE CAPACITY OF UI EXCEEDED ***') STOP ENDIF C IF (WEIGHT.EQ.1) THEN READ(2,*) UR(IRW) ELSE UR(IRW) = ONE ENDIF IF (ICSET.GT.1) MKTSHR(ICH) = MKTSHR(ICH) + UR(IRW) RLL0 = RLL0 + UR(IRW)*LOG(REAL(UI(INALT))) C IF (NRVAR.EQ.0) THEN READ(2,*) UI(IIRV), (UR(IRCDAT+K),K=1,UI(IIRV)) IRCDAT = IRCDAT + UI(IIRV) ENDIF IF (NRVAR.GT.0) THEN READ(2,*) (UR(IRCDAT+K),K=1,NRVAR) UI(IIRV) = NRVAR IRCDAT = IRCDAT + NRVAR ENDIF IF (IRCDAT.GT.LUR) THEN WRITE(IOUNIT,630) 630 FORMAT(/,' *** STORAGE CAPACITY OF UR EXCEEDED ***') STOP ENDIF IICH = IICH + 1 INALT = INALT + 1 IIIV = IIIV + 1 IIRV = IIRV + 1 IRW = IRW + 1 640 CONTINUE CLOSE(2) C CALL IVSET(1, IV, LIV, LV, V) C C *** SET REGRESSION DIAGNOSTIC CONSTANTS IV(83) = NFIX IV(84) = LOO IV(85) = IV85 IV(86) = IV86 IV(87) = IV87 IV(88) = 0 IV(89) = 0 IV(90) = IV90 C C IV(RDREQ) = 1 + 2*RDR IV(57) = 1 + 2*RDR C C IV(COVPRT) = 3 IV(14) = 5 C C SET IV(COVREQ) IF (COVTYP.EQ.1) IV(15) = -2 IF (COVTYP.EQ.2) IV(15) = 3 C C-------------------------------------------------------------------- C THE FOLLOWING COMMENTED-OUT CODE COULD BE USED TO ALTER C CONVERGENCE TOLERANCES: C (EXAMPLE: CALCULATE TOLERANCES AS THOUGH MACHEP WERE THE C SQUARE ROOT OF THE ACTUAL MACHEP) C MACHEP = SQRT(ETA0) C MEPCRT = MACHEP *** (ONE/THREE) C V(RFCTOL) = MAX(1.E-10, MEPCRT**2) C V(SCTOL) = V(RFCTOL) C V(XCTOL) = SQRT(MACHEP) C C WRITE(IOUNIT,650) V(RFCTOL), V(XCTOL) C650 FORMAT(//,' Relative F-Convergence tolerance: ',d13.6,/, C 1 ' Relative X-Convergence tolerance: ',d13.6,//) C-------------------------------------------------------------------- C IF (IV(1).NE.12) THEN WRITE(IOUNIT,*) ' There was a problem with calling IVSET' STOP ENDIF C C *** SET MODE TO FIXED, UNIT SCALING IN OPTIMIZATION *** C *** IV(DYTYPE) = IV(16) = 0. V(DINIT) = V(38) = 1. *** IV(16) = 0 V(38) = ONE C *** THERE ARE NO "NUISANCE PARAMETERS" IN THIS IMPLEMENTATION *** NPS = NPAR C C *** ALLOCATE STORAGE AND OPTIMIZE C CALL GLG(NOBS, NPAR, NPS, X, PCMRHO, RHOI, RHOR, IV, LIV, LV, V, 1 PCMRJ, UI, UR, MECDF) C-------------------------------------------------------------------- C *** COMPUTE ASYMPTOTIC T-STATISTICS *** C IH = ABS(IV(26)) - 1 IF (IH.GT.0) THEN DO 660 I = 1, NPAR IH = IH + I STDERR(I) = SQRT(V(IH)) IF (STDERR(I).GT.0) THEN TSTAT(I) = X(I)/STDERR(I) ELSE STDERR(I) = ZERO TSTAT(I) = ZERO ENDIF 660 CONTINUE C WRITE(IOUNIT,670) 670 FORMAT(/,' ASYMPTOTIC T-STATISTICS: ',/, 1 2X,'I',16X,'X(I)'11X,'T-STAT(I)', 2 7X,'STD ERROR') C DO 690 I = 1, NPAR WRITE(IOUNIT,680) I, VNAME(I), X(I), TSTAT(I), STDERR(I) 680 FORMAT(1X,I2,2X,A8,2X,E13.6,2(3X,E13.6)) 690 CONTINUE ENDIF C RLLR = TWO*(RLL0 - V(10)) WRITE(IOUNIT,700) NOBS, -V(10), -RLL0, RLLR 700 FORMAT(/,' NUMBER OF OBSERVATIONS (NOBS) = ',I4,//, 1 ' LOG-LIKELIHOOD L(EST) = ',E13.6,/, 1 ' LOG-LIKELIHOOD L(0) = ',E13.6,/, 1 ' -2[L(0) - L(EST)]: = ',E13.6,/) C IF (WEIGHT.EQ.0) THEN RHOSQR = ONE - V(10)/RLL0 RSQHAT = ONE - (V(10)+NPAR)/RLL0 WRITE(IOUNIT,710) RHOSQR, RSQHAT 710 FORMAT(' 1 - L(EST)/L(0): = ',E13.6,/, 1 ' 1 - (L(EST)-NPAR)/L(0) = ',E13.6,/) ELSE WRITE(IOUNIT, 720) 720 FORMAT(' WEIGHTS USED: RHO-SQUARES NOT REPORTED.',/) ENDIF IF (ICSET.GT.1) THEN WRITE(IOUNIT,730) 730 FORMAT(' (FIXED CHOICE SET SIZE)',//, 1 ' AGGREGATE CHOICES AND MARKET SHARES: ') IF (WEIGHT.EQ.1) WRITE(IOUNIT,740) 740 FORMAT(' (WEIGHTED)') RLLC = ZERO RNOBS = NOBS DO 760 I = 1, ICSET RNI = MKTSHR(I) RFI = RNI/RNOBS IF (RFI.GT.ZERO) RLLC = RLLC + RNI*LOG(RFI) WRITE(IOUNIT,750) I, MKTSHR(I), RFI 750 FORMAT(1X,I3,2X,F10.3,2X,F6.4) 760 CONTINUE RLLR = TWO * (-RLLC - V(10)) WRITE(IOUNIT, 770) RLLC, RLLR 770 FORMAT(/,' STATISTICS FOR CONSTANTS-ONLY MODEL:',/, 1 ' LOG-LIKELIHOOD L(C) = ',E13.6,/, 1 ' -2[L(C) - L(EST)]: = ',E13.6,/) ENDIF C IF (IPRNT.EQ.1) 1 CALL FPRINT(NOBS, NPAR, X, NF, UI, UR, MECDF) C WRITE(IOUNIT,780) 780 FORMAT(//,' OUTPUT FOR CONVENIENT RESTART:') DO 800 I = 1, NPAR WRITE(IOUNIT,540) VNAME(I) WRITE(IOUNIT,790) X(I), B(1,I), B(2,I) 790 FORMAT(1X,3(1X,E13.6)) 800 CONTINUE C *** LAST LINE OF MLMNP FOLLOWS *** END //GO.SYSIN DD smlmnp.f cat >smlmnpb.f <<'//GO.SYSIN DD smlmnpb.f' PROGRAM MLMNPB C C VERSION: SEPTEMBER 4, 1991 C C *** MAXIMUM LIKELIHOOD ESTIMATION OF THE LINEAR-IN-PARAMETERS *** C *** MULTINOMIAL PROBIT MODEL (VIA MENDELL-ELSTON PROBABILITIES). *** C *** SEE REFERENCES BELOW. *** C C *** THIS VERSION DOES IMPOSE SIMPLE BOUNDS ON THE PARAMETERS. *** C *** THIS VERSION DOES NOT CALCULATE T-SCORES AND REGRESSION *** C *** DIAGNOSTICS. *** C C *** THIS PROGRAM UTILIZES A GENERAL FRAMEWORK FOR MLE OF A *** C *** PROBABILISTIC CHOICE MODEL AND MAY BE MODIFIED FOR USE WITH *** C *** OTHER CHOICE MODELS. (SEE "PROTOTYE PROGRAM" DISCUSSION.) *** C C PROGRAM MLEPCM ("PROTOTYPE PROGRAM") C *** MAXIMUM LIKELIHOOD ESTIMATION OF PROBABILISTIC CHOICE MODELS *** C C *** DESCRIPTION *** C C THIS PROGRAM PERFORMS MAXIMUM LIKELIHOOD ESTIMATION BY MINIMIZING C THE NEGATIVE OF THE LOG-LIKELIHOOD FUNCTION. THE FUNCTION IS WRITTEN C AS C C -SUM{FOR I=1, NOBS} WT(I)*LOG P[ICH(I), IX(I), RX(I)] C C WHERE: C P[ICH(I), IX(I), RX(I)] IS A GENERAL PROBABILISTIC CHOICE MODEL, C ICH(I) IS THE CHOICE MADE FOR OBSERVATION I, C IX(I) CONTAINS INTEGER EXPLANATORY DATA SPECIFIC TO OBSERVATION I C (E.G., A LIST OF ALTERNATIVES IN THE CHOICE SET), C RX(I) CONTAINS REAL EXPLANATORY DATA SPECIFIC TO OBSERVATION I, C AND WT(I) IS A WEIGHT FOR OBSERVATION I. C C THIS PROGRAM IS DESIGNED TO CALL THE GENERALIZED REGRESSION C OPTIMIZATION SUBROUTINES GLG AND GLGB, WHICH IN TURN CALL RGLG C AND RGLGB, ETC. A FEW LEVELS DOWN, THE PROBABILITY C P[ICH(I), IX(I), RX(I)] IS COMPUTED IN A USER-SUPPLIED SUBROUTINE C CALCPR, USING THE FOLLOWING CALL: C C CALL CALCPR(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, C 1 PROB, IUSER, RUSER, MNPCDF) C C FOR A DESCRIPTION OF PARAMETER USAGE, SEE THE SUBROUTINE. C C *** MLEPCM PARAMETER DECLARATIONS *** C C SCALARS: C INTEGER BS, COVTYP, ICSET, IDR, IOUNIT, NB, NFIX, NIUSER INTEGER NIVAR, NOBS, NPAR, NRUSER, NRVAR, WEIGHT, XNOTI C C ARRAYS: C INTEGER IV(300), RHOI(28000), UI(24000) REAL B(2,60), RHOR(164000), UR(160000), V(268105) REAL X(60) EQUIVALENCE (RHOI(1), UI(1)), (RHOR(1), UR(1)) CHARACTER*8 VNAME(60) C C LENGTHS OF ARRAYS: C INTEGER LIV, LRHOI, LRHOR, LUI, LUR, LV, LX C C INTEGER IV(LIV), RHOI(LRHOI), UI(LUI) C REAL B(2,LX), RHOR(LRHOR), UR(LUR), V(LV), X(LX) C C SUBROUTINES: C REAL R7MDC EXTERNAL GLGB, IVSET, R7MDC, FPRINT, MECDF, PCMRHO, PCMRJ C C *** MLEPCM PARAMETER USAGE *** C C (SEE EXPLANATIONS BELOW) C C SCALARS: C C BS...... BLOCK-SIZE, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS ARE C REQUESTED AND ALL BLOCKS ARE THE SAME SIZE (SEE BELOW). C COVTYP.. INDICATES TYPE OF VARIANCE-COVARIANCE MATRIX APPROXIMATION. C = 1 FOR H^-1, WHERE H IS THE FINITE-DIFFERENCE HESSIAN C AT THE SOLUTION. C = 2 FOR (J^T J)^-1, I.E., THE GAUSS-NEWTON HESSIAN C APPROXIMATION AT THE SOLUTION. C ICSET... INDICATOR OF FIXED- OR VARIABLE-SIZE CHOICE SETS. C IDR..... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C IOUNIT.. OUTPUT UNIT NUMBER FOR PRINTING ERROR MESSAGES. C = FORTRAN UNIT FOR IOUNIT > 0. DEFAULT = 6. C IPRNT... INDEX INDICATING PRINT OPTIONS. C = 0 FOR NO ADDITIONAL PRINTING. C = 1 FOR FINAL CHOICE PROBABILITIES. C (DEFAULT = 0.) C WEIGHT. INDICATOR FOR USER-PROVIDED WEIGHTS. C NB...... NUMBER OF BLOCKS, IF LEAVE-BLOCK-OUT REGRESSION DIAGNOSTICS C ARE REQUESTED (SEE BELOW). C NFIX.... PARAMETER USED BY RGLG. NFIX = 0. C NIVAR... NUMBER OF (INTEGER) DATA VARIABLES PER CHOICE SET. C NIUSER.. NUMBER OF (INTEGER) USER-SPECIFIED CONSTANTS. C NOBS.... NUMBER OF OBSERVATIONS. C NPAR.... NUMBER OF MODEL PARAMETERS (X COMPONENTS). C NRVAR... NUMBER OF (REAL) DATA VARIABLES PER CHOICE SET. C NRUSER.. NUMBER OF (REAL) USER-SPECIFIED CONSTANTS. C XNOTI... INDICATOR FOR TYPE OF REGRESSION DIAGNOSTICS (SEE BELOW). C C ARRAYS AND ARRAY LENGTHS: C C B....... REAL ARRAY OF UPPER AND LOWER BOUNDS ON PARAMETER VALUES. C IV...... INTEGER VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C LIV..... LENGTH OF IV; MUST BE AT LEAST 90 + NPAR. CURRENT LIV = 300. C LV...... LENGTH OF LV; MUST BE AT LEAST C 105 + P*(3*P + 16) + 2*N + 4P + N*(P + 2), WHERE C P = NPAR AND N = NOBS. FOR P = 60 AND N = 4000, THIS C EXPRESSION GIVES 268105. CURRENT LV = 268105. C LRHOI... LENGTH OF RHOI. CURRENT LRHOI = LUI + 4000 = 28000. C LRHOR... LENGTH OF RHOR. CURRENT LRHOR = LUR + 4000 = 164000. C LUI..... LENGTH OF UI. CURRENT LUI = 24000. C LUR..... LENGHT OF UR. CURRENT LUR = 160000. C LX...... LENGTH OF PARAMETER VECTOR X. CURRENT LX = 30. C RHOI.... INTEGER VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO PASS BLOCK-SIZES IF LEAVE-BLOCK-OUT C REGRESSION DIAGNOSTICS WITH VARIABLE BLOCK-SIZES ARE C REQUESTED (SEE BELOW). (CURRENT PCMRHO MAKES USE OF C RHOI THROUGH EQUIVALENCE OF RHOI WITH UI.) C RHOR.... REAL VALUE ARRAY PASSED WITHOUT CHANGE TO PCMRHO. C ALSO USED TO STORE X(I) VECTORS, IF SUCH REGRESSION C DIAGNOSTICS ARE REQUESTED (SEE BELOW). (CURRENT PCMRHO C MAKES USE OF RHOR THROUGH 2EQUIVALENCE OF RHOR WITH UR.) C UI...... INTEGER VALUE ARRAY FOR USER STORAGE (SEE BELOW). C UI(1) TO UI(10) STORE MLEPCM PARAMETERS FOR USE IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C UR...... REAL VALUE ARRAY FOR USER STORAGE (SEE BELOW). C V....... REAL VALUE ARRAY USED BY OPTIMIZATION ROUTINES. C VNAME... ARRAY OF PARAMETER NAMES FOR X COMPONENTS BEING ESTIMATED. C X....... PARAMETER VECTOR BEING ESTIMATED. C C SUBROUTINES: C C PCMRJ... SUBROUTINE THAT CALCULATES GENERALIZED RESIDUAL VECTOR, C AND THE JACOBIAN OF THE GENERALIZED RESIDUAL VECTOR. C SEE DISCUSSION OF "CALCRJ" IN GLG. C PCMRHO.. SUBROUTINE THAT CALCULATES THE CRITERION FUNCTION, AND C ITS DERIVATIVES. SEE DISCUSSION OF "RHO" IN RGLG. C MECDF... SUBROUTINE THAT CALCULATES THE MULTIVARIATE NORMAL CDF C USING THE FIXED-ORDER MENDELL-ELSTON APPROXIMATION. C PASSED WITHOUT CHANGE TO CALCPR. (COULD BE REPLACED C WITH ANOTHER CDF ROUTINE IF DESIRED.) C C C *** DISCUSSION FOR MLEPCM *** C C *** DATA INPUT STREAM *** C C *** GENERAL PARAMETERS ARE READ IN FIRST FROM "INPUT BLOCK 1": *** C C READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT,COVTYP,IDR C C THESE PARAMETERS ARE INTENDED TO GIVE A FLEXIBLE INPUT C FORMAT FOR CHOICE MODELS, WITH SOME SHORTCUTS FOR SIMPLE CASES. C SPECIFIC SETTINGS OF THE ABOVE PARAMETERS WILL PRODUCE DIFFERENCES C IN THE INPUT STREAM FORMAT. C C FOR ICSET = 0 (OR 1) A VARIABLE NUMBER OF ALTERNATIVES PER CHOICE C SET IS USED. THE USER MUST PROVIDE THIS NUMBER FOR EACH C OBSERVATION. C FOR ICSET > 1 EACH CHOICE SET IS ASSUMED TO INCLUDE ICSET C ALTERNATIVES. C C WEIGHT = 1 MEANS THAT EACH OBSERVATION REQUIRES A WEIGHT, WHICH C MUST BE PROVIDED BY THE USER. C WEIGHT = 0 MEANS THAT ALL OBSERVATIONS AUTOMATICALLY RECEIVE EQUAL C WEIGHT AND THEREFORE NO USER-SUPPLIED WEIGHTS ARE REQUIRED. C C FOR NIVAR = -1 NO INTEGER DATA VALUES ARE REQUIRED BY THE MODEL. C FOR NIVAR = 0 A VARIABLE NUMBER OF INTEGER DATA VALUES IS STORED C PER OBSERVATION. IN THIS CASE, THE USER MUST INCLUDE FOR EACH C OBSERVATION THE NUMBER OF INTEGER VALUES TO BE STORED FOLLOWED C BY THE INTEGER VALUES THEMSELVES. (THIS MIGHT BE USED IN C CONJUNCTION WITH ICSET=0 TO LIST NOMINAL VARIABLES FOR THE C CHOICE ALTERNATIVES IN THE CHOICE SET.) C FOR NIVAR > 0 EACH OBSERVATION IS ASSUMED TO INCLUDE NIVAR INTEGERS. C C FOR NRVAR THE USAGE IS ANALOGOUS TO NIVAR, ONLY FOR REAL DATA. C C NIUSER AND NRUSER ARE USED TO INDICATE THE NUMBER OF CONSTANTS C TO BE PASSED TO THE MODEL SUBROUTINES. THESE ARE MODEL SPECIFIC. C FOR SOME CODES NIUSER, NRUSER, AND PERHAPS THE CONSTANTS, MIGHT C BE SET IN THE MAIN PROGRAM AND NOT BY THE INPUT STREAM. C C FOR MORE DETAILS ON THIS, SEE THE ACTUAL CODE BELOW. C C IN ADDITION TO DATA STORAGE, MLEPCM PROVIDES A RATHER FLEXIBLE C CHOICE OF STATISTICAL ANALYSES. IN THE VERSION OF THE PROGRAM C WHICH ENFORCES BOUNDS, STATISTICS ARE NOT CALCULATED. HOWEVER, C FOR CONVENIENCE IT IS ASSUMED THAT THE SAME INPUT STREAM IS USED C FOR BOTH PROGRAMS. C C TO CALCULATE ASYMPTOTIC T-SCORES, A VARIANCE-COVARIANCE MATRIX C APPROXIMATION IS REQUIRED. SEE COVTYP ABOVE. C C TO PERFORM REGRESSION DIAGNOSTICS, THE FOLLOWING PARAMETERS C ARE USED: C C IDR = 0 IF NO REGRESSION DIAGNOSTICS ARE DESIRED. C C = 1 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)), WHERE X(I) C MINIMIZES F (THE NEGATIVE LOG-LIKELIHOOD) WITH C OBSERVATION I REMOVED, AND X* IS THE MLE FOR THE FULL C DATASET. ("LEAVE-ONE-OUT" DIAGNOSTICS.) C C = 2 FOR ONE-STEP ESTIMATES OF F(X*)-F(X(I)) AS WHEN IDR = 1, C AND ALSO THE ONE-STEP ESTIMATES OF X(I), I = 1 TO NOBS. C C = 3 FOR "LEAVE-BLOCK-OUT" DIAGNOSTICS. (DISCUSSION FOLLOWS.) C C *** PARAMETERS RELATED TO "LEAVE-BLOCK-OUT" REGRESSION DIAGNOSTICS *** C *** READ NEXT FROM "INPUT BLOCK 2" (IF APPLICABLE). *** C C "LEAVE-BLOCK-OUT" DIAGNOSTICS C C IN THIS CASE, ONE OR MORE ADDITIONAL LINES OF DATA ARE C REQUIRED. IF IDR = 3, THE FOLLOWING STATEMENT IS EXECUTED: C C READ(1,*) BS, NB, XNOTI C C NB = NUMBER OF BLOCKS C C XNOTI = 0 IF NO X(I) DIAGNOSTICS ARE REQUESTED, C = 1 OTHERWISE. C C BS > 0 MEANS THAT FIXED BLOCK SIZES OF SIZE BS ARE USED. C IN THIS CASE NB * BS = NOBS, AND THE PROGRAM C PROCEEDS TO "INPUT BLOCK 3" FOR MNP INPUT PARAMETERS. C C BS = 0 MEANS THAT VARIABLE BLOCK SIZES ARE USED. C IN THIS CASE THE NEXT FORMAT STATEMENT READS C THE BLOCK SIZES INTO RHOI USING FREE FORMAT: C C LR1 = LUI + 1 C LR2 = LR1 + NB C READ(1,*) (RHOI(I),I=LR1,LR2) C C *** THE PROGRAM THEN PROCEEDS TO "INPUT BLOCK 3" TO READ MODEL-*** C *** RELATED PARAMETERS. SEE DISCUSSION FOR MNP MODEL BELOW. *** C C *** INPUT BLOCK 4 CONTAINS THE INITIAL GUESS FOR THE SEARCH. *** C *** IT INCLUDES VARIABLE NAMES, A STARTING GUESS, AND BOUNDS. *** C C DO 10 I = 1, NPAR C READ(1,3) VNAME(I) C 3 FORMAT(1X,A8) C READ(1,*) X(I), B(1,I), B(2,I) C WRITE(IOUNIT,4) I, VNAME(I),X(I), B(1,I), B(2,I) C 4 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) C 10 CONTINUE C CLOSE(1) C C *** FOR THE LINEAR-IN-PARAMETERS MNP MODEL, THE ORDERING OF *** C *** PARAMETERS IS AS FOLLOWS: *** C C 1. MEAN TASTE WEIGHTS FOR GENERIC ATTRIBUTES (NATTR OF THESE). C 2. ALTERNATIVE-SPECIFIC MEANS (NALT-1 OF THESE). C 3. COVARIANCE PARAMETERS FOR ALTERNATIVE-SPECIFIC ERRORS. C THERE ARE 2(NALT-1)(NALT)/2 - 1 OF THESE, IN THE FORM OF C CHOLESKY DECOMPOSITION, STORED ROW-WISE: C B21 B22 C B31 B32 B33 C B(J-1,1) B(J-1,2) ..........B(J-1,J-1) C WHERE B11 = SCALE IS ASSUMED. C SEE BUNCH(1991, TRANSP. RES. B, VOL. 1, PP. 1-12); NOTE C THE MISPRINT IN EQUATION (26). C (NOTE THAT PARAMETERS ARE READ IN ONE PARAMETER PER LINE.) C 4. COVARIANCE PARAMETERS FOR TASTE VARIATION. C NATTR VARIANCES IF ITASTE=1 (UNCORRELATED). C NATTR*(NATTR+1)/2 CHOLESKY PARAMETERS IF ITASTE=2 C (I.E., CORRELATED). C C *** UNIT 1 IS CLOSED, AND THE MODEL DATA IS READ FROM UNIT 2. *** C *** ITS FORMAT IS CONTROLLED BY THE GENERAL PARAMETERS ABOVE. *** C *** FOR THE SPECIFIC FREE-FORMAT READ STATEMENTS, SEE THE MAIN *** C *** BODY OF THE CODE. *** C C C *** MULTINOMIAL PROBIT MODEL PARAMETERS *** C (PARAMETERS SPECIFIC TO THIS MODEL IMPLEMENTATION) C INTEGER IDUM, ICOV, ITASTE, NALT, NATTR INTEGER IUSER(18) EQUIVALENCE (UI(11),IUSER(1)) C C *** PARAMETER USAGE *** C C THE FOLLOWING ARE USER-PROVIDED INTEGER CONSTANTS: C C IDUM.... INDICATOR FOR ALTERNATIVE-SPECIFIC DUMMIES, C = 0 FOR NO, = 1 FOR YES. IF ICSET .NE. 0, THEN C THE SAME SET OF DUMMIES IS USED FOR EACH CHOICE SET. C OTHERWISE, INTEGER DATA SHOULD BE USED TO IDENTIFY THE C ALTERNATIVES IN EACH CHOICE SET (SEE NALT BELOW). C ICOV.... INDICATOR FOR TYPE OF ALTERNATIVE-SPECIFIC ERRORS, C = 0 FOR IID ERRORS, = 1 FOR CORRELATED ERRORS. C IF ICSET .NE. 0, THEN THE SAME CORRELATION MATRIX IS C USED FOR EVERY SUBSET. OTHERWISE, INTEGER DATA SHOULD C BE USED TO IDENTIFY THE ALTERNATIVES IN EACH CHOICE SET. C ITASTE.. INDICATOR FOR TASTE VARIATION, C = 0 FOR NO TASTE VARIATION, = 1 FOR UNCORRELATED TASTE C VARIATION, = 2 FOR CORRELATED TASTE VARIATION. C IUSER... INTEGER ARRAY THAT STORES MNP MODEL PARAMETERS USED IN C SUBROUTINES PCMRJ, PCMRHO, CALCPR, ETC. C NALT.... TOTAL NUMBER OF NOMINAL CHOICE ALTERNATIVES (IF APPLICABLE). C IF ICSET .NE. 0, THEN NALT IS SET EQUAL TO ICSET. C OTHERWISE, NALT SHOULD BE > 0 IF EITHER IDUM OR ICOV C (OR BOTH) ARE > 0. C NATTR... NUMBER OF ATTRIBUTES (I.E., REAL DATA VARS.) PER ALTERNATIVE. C C C *** READ STATEMENT FOR INPUT BLOCK 3 *** C C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER I, ICH, ICHECK, ICP, IETA0, II, IICDAT, IICH, IIIV, IIRV, 1 IIU, INALT, IOBS, IPCOEF, IPCOV, IPDUM, IPRNT, IPTAST, 2 IRCDAT, IRU, IRW, ISCALE, ISIGP, ISIGU, ITST, IV85, IV86, 3 IV87, IV90, K, LCOVP, LCOVU, LCOVX, LOO, LRI1, LRR1, 4 LW, NBSCHK, NF, NPCHK, NPS, NRICHK, NRRCHK, RDR REAL MKTSHR(20) REAL RFI, RHOSQR, RSQHAT, RLL0, RLLC, RLLR, RNI, 1 RNOBS, SCALE C REAL ETA0, MACHEP, MEPCRT, ONE, TWO, ZERO C DATA ZERO/0.E0/ DATA ONE/1.E0/ DATA TWO/2.E0/ C C *** GENERAL *** C C CODED BY DAVID S. BUNCH C SUPPORTED BY U.S. DEPARTMENT OF TRANSPORTATION THROUGH C REGION NINE TRANSPORTATION CENTER AT UNIVERSITY OF CALIFORNIA, C BERKELEY (WINTER-SUMMER 1991) C--------------------------------- BODY ------------------------------ C C *** INITIALIZE SOME PARAMETERS *** C (SEE DISCUSSION ABOVE) NFIX = 0 LIV = 300 LRI1 = 24001 LRHOI = 28000 LRHOR = 164000 LRR1 = 160001 LV = 268105 LUI = 24000 LUR = 160000 LX = 60 C C *** READ MLEPCM PARAMETERS FROM INPUT BLOCK 1 *** C OPEN(1,FILE='fort.1') REWIND 1 OPEN(2,FILE='fort.2') REWIND 2 READ(1,*) NPAR,NOBS,ICSET,WEIGHT,NIVAR,NRVAR,IOUNIT,IPRNT, 1 COVTYP,IDR C IF (IOUNIT.LE.0) THEN IOUNIT = 6 WRITE(IOUNIT,10) 10 FORMAT(/' *** INVALID IOUNIT SET EQUAL TO 6 ***',//) ENDIF C WRITE(IOUNIT,20) 20 FORMAT(' PROGRAM MLMNPB',//,' MAXIMUM LIKELIHOOD ESTIMATION OF', 1 /,' LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS',/, 1 ' (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED)',//) WRITE(IOUNIT,30) NOBS 30 FORMAT(' NUMBER OF OBSERVATIONS.................',I4) IF (ICSET.EQ.1) ICSET = 0 IF (ICSET.EQ.0) THEN WRITE(IOUNIT,40) 40 FORMAT(' FLEXIBLE CHOICE SETS USED') ELSE WRITE(IOUNIT,50) ICSET 50 FORMAT(' NUMBER OF ALTERNATIVES PER CHOICE SET..',I4) ENDIF IF (WEIGHT.EQ.1) THEN WRITE(IOUNIT,60) 60 FORMAT(' USER-PROVIDED WEIGHTS USED') ELSE WRITE(IOUNIT,70) 70 FORMAT(' EQUAL WEIGHTS FOR ALL OBSERVATIONS') ENDIF IF (NIVAR.EQ.-1) THEN WRITE(IOUNIT,80) 80 FORMAT(' NO INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.EQ.0) THEN WRITE(IOUNIT,90) 90 FORMAT(' FLEXIBLE INTEGER EXPLANATORY VARIABLES') ENDIF IF (NIVAR.GT.0) THEN WRITE(IOUNIT,100) NIVAR 100 FORMAT(' NUMBER OF INTEGER DATA VALUES PER OBS..',I4) ENDIF IF (NRVAR.EQ.-1) THEN WRITE(IOUNIT,110) 110 FORMAT(' NO REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.EQ.0) THEN WRITE(IOUNIT,120) 120 FORMAT(' FLEXIBLE REAL EXPLANATORY VARIABLES') ENDIF IF (NRVAR.GT.0) THEN WRITE(IOUNIT,130) NRVAR 130 FORMAT(' NUMBER OF REAL DATA VALUES PER OBS.....',I4) ENDIF WRITE(IOUNIT,140) IOUNIT 140 FORMAT(' OUTPUT UNIT............................',I4,/) IF ((COVTYP.NE.1).AND.(COVTYP.NE.2)) THEN COVTYP = 1 WRITE(IOUNIT,150) 150 FORMAT(' *** INVALID COVTYP SET TO 1 ***',/) ENDIF IF (COVTYP.EQ.1) WRITE(IOUNIT,160) 160 FORMAT(' COVARIANCE TYPE = INVERSE FINITE-DIFFERENCE HESSIAN') IF (COVTYP.EQ.2) WRITE(IOUNIT,170) 170 FORMAT(' COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN') IF ((IDR.LT.0).OR.(IDR.GT.3)) THEN IDR = 0 WRITE(IOUNIT,180) 180 FORMAT(/,' *** INVALID IDR SET TO 0 ***',/) ENDIF IF (IDR.EQ.0) WRITE(IOUNIT,190) 190 FORMAT(' NO REGRESSION DIAGNOSTICS REQUESTED') IF (IDR.GE.1) WRITE(IOUNIT,200) 200 FORMAT(' REGRESSION DIAGNOSTICS REQUESTED') IF ((IDR.EQ.1).OR.(IDR.EQ.2)) WRITE(IOUNIT,210) 210 FORMAT(' STANDARD LEAVE-ONE-OUT DIAGNOSTICS REQUESTED') IF (IDR.EQ.2) WRITE(IOUNIT,220) 220 FORMAT(' DIAGNOSTICS ON X-VECTOR REQUESTED') IF (IDR.EQ.3) WRITE(IOUNIT,230) 230 FORMAT(/,' *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED ***') WRITE(IOUNIT,*) C C *** PROCESS REGRESSION DIAGNOSTICS *** C IF (IDR.EQ.0) RDR = 0 C IF (IDR.EQ.1) THEN RDR = 1 LOO = 0 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = 0 IV90 = 0 NRICHK = LUI + 1 NRRCHK = 0 ENDIF C IF (IDR.EQ.2) THEN RDR = 2 LOO = 1 IV85 = LRI1 RHOI(LRI1) = 1 IV86 = 0 IV87 = NOBS IV90 = LRR1 NRICHK = LUI + NOBS NRRCHK = LUR + NOBS * NPAR ENDIF C C *** INPUT FOR SPECIAL REGRESSION DIAGNOSTICS *** C *** BEGIN READING "INPUT BLOCK 2" *** C IF (IDR.EQ.3) THEN READ(1,*) BS, NB, XNOTI C IF (BS.LT.0) THEN BS = 0 WRITE(IOUNIT,240) 240 FORMAT(/,' *** NEGATIVE BLOCK-SIZE (BS) SET TO 0 ***',/) ENDIF C IF (NB.LE.0) THEN WRITE(IOUNIT,250) 250 FORMAT(/,' *** INVALID NO. OF BLOCKS (NB). STOP. ***',/) STOP ENDIF C IF ((XNOTI.NE.0).AND.(XNOTI.NE.1)) THEN XNOTI = 0 WRITE(IOUNIT,260) 260 FORMAT(/,' *** INVALID XNOTI SET TO 0. ***',/) ENDIF IF (XNOTI.EQ.1) WRITE(IOUNIT,220) WRITE(IOUNIT,270) NB 270 FORMAT(' NUMBER OF BLOCKS: ',I4) C RDR = 2 LOO = 2 IV85 = LRI1 IV86 = 0 IV87 = NB IF (XNOTI.EQ.1) THEN IV90 = LRR1 NRRCHK = LUR + NB * NPAR ENDIF C IF (BS.GT.0) THEN WRITE(IOUNIT,280) BS 280 FORMAT(' FIXED BLOCK SIZE: ',I4,/) IF (BS*NB.NE.NOBS) THEN WRITE(IOUNIT,290) 290 FORMAT(/,' *** (BS * NB) .NE. NOBS. STOP. ***',/) STOP ENDIF RHOI(LRI1) = BS NRICHK = LUI + 1 ELSE IV86 = 1 WRITE(IOUNIT,300) 300 FORMAT(' VARIABLE BLOCK-SIZE OPTION CHOSEN',/) NRICHK = LUI + NB ENDIF ENDIF C C *** CHECK SIZE OF RHOI *** IF (NRICHK.GT.LRHOI) THEN WRITE(IOUNIT,310) 310 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C *** IF VARIABLE-LENGTH BLOCKSIZES ARE USED, *** C *** READ THEM IN AND TEST THEM. *** IF (IV86.EQ.1) THEN READ(1,*) (RHOI(I),I=LRI1,NRICHK) WRITE(IOUNIT,320) 320 FORMAT(' BLOCK-SIZES: ') WRITE(IOUNIT,330) (RHOI(I),I=LRI1,NRICHK) 330 FORMAT(5X,15I5) WRITE(IOUNIT,*) ICHECK = 0 DO 350 I = LRI1, NRICHK IF (RHOI(I).LE.0) THEN ICHECK = 1 WRITE(IOUNIT,340) I-LUI 340 FORMAT(' *** BLOCK-SIZE ',I5,' IS INVALID ***') ENDIF NBSCHK = NBSCHK + RHOI(I) 350 CONTINUE IF (ICHECK.EQ.1) THEN WRITE(IOUNIT,360) 360 FORMAT(/,' *** CANNOT PROCEED WITH INVALID BLOCK-SIZES. ', 1 'STOP. ***') STOP ENDIF IF (NBSCHK.NE.NOBS) THEN WRITE(IOUNIT,370) 370 FORMAT(/,' *** SUM OF BLOCK-SIZES .NE. NOBS. STOP. ***') STOP ENDIF ENDIF C C *** CHECK SIZE OF RHOR *** IF (NRRCHK.GT.LRHOR) THEN WRITE(IOUNIT,380) 380 FORMAT(' *** STORAGE CAPACITY OF RHOI EXCEEDED. STOP. ***') STOP ENDIF C C C *** READ MNP PARAMETERS FROM INPUT BLOCK 3 *** C READ(1,*) NALT, NATTR, IDUM, ICOV, ITASTE C IF (ICSET.NE.0) THEN IF ((NALT.NE.0).AND.(NALT.NE.ICSET)) THEN WRITE(IOUNIT,390) 390 FORMAT(' *** NOTE: ERROR IN NALT OR ICSET ***') STOP ENDIF NALT = ICSET WRITE(IOUNIT,400) 400 FORMAT(' *** NOTE: NALT SET EQUAL TO ICSET ***') ENDIF IF (NALT.EQ.0) THEN WRITE(IOUNIT,410) 410 FORMAT(' NO NOMINAL VARIABLES') ELSE WRITE(IOUNIT,420) NALT 420 FORMAT(' NUMBER OF NOMINAL VARIABLES............',I4) ENDIF C WRITE(IOUNIT,430) NATTR 430 FORMAT(' NUMBER OF ATTRIBUTES PER ALTERNATIVE...',I4) IF (IDUM.EQ.0) THEN WRITE(IOUNIT,440) 440 FORMAT(' NO NOMINAL DUMMIES') ELSE WRITE(IOUNIT,450) 450 FORMAT(' NOMINAL DUMMIES USED') ENDIF IF (ICOV.EQ.0) THEN WRITE(IOUNIT,460) 460 FORMAT(' IID ERROR TERMS') ELSE WRITE(IOUNIT,470) 470 FORMAT(' CORRELATED ERROR TERMS') ENDIF IF (ITASTE.EQ.0) THEN WRITE(IOUNIT,480) 480 FORMAT(' NO RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.1) THEN WRITE(IOUNIT,490) 490 FORMAT(' UNCORRELATED RANDOM TASTE VARIATION') ENDIF IF (ITASTE.EQ.2) THEN WRITE(IOUNIT,500) 500 FORMAT(' CORRELATED RANDOM TASTE VARIATION') ENDIF C WRITE(IOUNIT,510) NPAR 510 FORMAT(/,' NUMBER OF MODEL PARAMETERS.............',I4,/) C C *** CHECK INITIAL DATA *** C (ADD MORE ERROR CHECKING HERE?) C IF (((IDUM.NE.0).OR.(ICOV.NE.0)).AND.(NALT.EQ.0)) THEN WRITE(IOUNIT,520) 520 FORMAT(' *** ERROR WITH IDUM OR ICOV OR NALT OR ICSET ***') STOP ENDIF C C *** CHECK NPAR *** C NPCHK = NATTR IF (IDUM.EQ.1) NPCHK = NPCHK + NALT - 1 LCOVX = 0 LCOVP = 0 LCOVU = 0 IF (ICOV.EQ.1) THEN LCOVX = NALT*(NALT-1)/2 - 1 NPCHK = NPCHK + LCOVX LCOVP = NALT*(NALT+1)/2 LCOVU = NALT*NALT ENDIF IF (ITASTE.EQ.1) NPCHK = NPCHK + NATTR IF (ITASTE.EQ.2) NPCHK = NPCHK + NATTR*(NATTR+1)/2 IF (NPAR.NE.NPCHK) THEN WRITE(IOUNIT,*) ' NPCHK = ',NPCHK WRITE(IOUNIT,*) ' INCORRECT NUMBER OF MODEL PARAMETERS' STOP ENDIF C C *** READ INITIAL PARAMETER ESTIMATES FROM UNIT 1 *** C WRITE(IOUNIT,530) 530 FORMAT(' INITIAL PARAMETER VECTOR AND BOUNDS: ') DO 560 I = 1, NPAR READ(1,540) VNAME(I) 540 FORMAT(1X,A8) READ(1,*) X(I), B(1,I), B(2,I) WRITE(IOUNIT,550) I, VNAME(I),X(I), B(1,I), B(2,I) 550 FORMAT(1X,I2,1X,A8,2X,3(1X,E13.6)) 560 CONTINUE CLOSE(1) C C *** SET UP UI STORAGE POINTERS (FOR MLEPCM) *** C C NIUSER AND NRUSER ARE USED TO RESERVE STORAGE FOR THE USER. C NIUSER AND NRUSER FOR MNP APPLICATION: C NIUSER = 18 LW = MAX(NATTR * NALT, LCOVP) NRUSER = LW + LCOVU + 2 C C (SEE HOW UI AND UR ARE USED BELOW TO PASS MNP INFORMATION) C C MLEPCM ARRAY POINTERS FOR UI: IIU = 11 IICH = NIUSER + IIU INALT = IICH + NOBS IIIV = INALT + NOBS IIRV = IIIV + NOBS IICDAT = IIRV + NOBS C C MLEPCM ARRAY POINTERS FOR UR: IRU = 1 ICP = IRU + NRUSER IRW = ICP + 2*NOBS IRCDAT = IRW + NOBS C C MLEPCM STORES POINTERS IN UI(1) THROUGH UI(10): UI(1) = IIU UI(2) = IICH UI(3) = INALT UI(4) = IIIV UI(5) = IIRV UI(6) = IICDAT UI(7) = IRU UI(8) = ICP UI(9) = IRW UI(10) = IRCDAT C C *** STORE MNP MODEL CONSTANTS STARTING IN IUSER(1) (=UI(11)) *** C C STORAGE FOR PASSING INVOCATION COUNTS: C UI(11) = NF1 = IUSER(1) C UI(12) = NF2 = IUSER(2) C C BASIC MNP MODEL INFORMATION: IUSER(3) = IOUNIT IUSER(4) = WEIGHT IUSER(5) = ICSET IUSER(6) = NALT IUSER(7) = NATTR IUSER(8) = IDUM IUSER(9) = ICOV IUSER(10) = ITASTE C C X ARRAY POINTERS (POINT TO START POSITION - 1): II = 0 IF (NATTR.NE.0) THEN IPCOEF = II II = II + NATTR ENDIF IF (IDUM.NE.0) THEN IPDUM = II II = II + NALT - 1 ENDIF IF (ICOV.NE.0) THEN IPCOV = II II = II + LCOVX ENDIF IF (ITASTE.NE.0) IPTAST = II C IUSER(11) = IPCOEF IUSER(12) = IPDUM IUSER(13) = IPCOV IUSER(14) = IPTAST C C ETA0 POINTER: IETA0 = 1 IUSER(17) = IETA0 C C SCALE POINTER: ISCALE = 2 IUSER(18) = ISCALE C C SIGMA (AND W) POINTERS: ISIGP = 3 C IW = ISIGP (W AND SIGP SHARE THE SAME STORAGE) ISIGU = ISIGP + LW C IUSER(15) = ISIGP IUSER(16) = ISIGU C C *** SET UP RUSER INFORMATION FOR MNP MODEL USE *** C C SET ETA0 EQUAL TO MACHEP C (ETA0 IS USED BY FINITE-DIFFERENCE ROUTINE S7GRD.) ETA0 = R7MDC(3) UR(IETA0) = ETA0 C C (SCALE SETS THE SCALING OF THE PROBIT MODEL COVARIANCE MATRIX) SCALE = ONE UR(ISCALE) = SCALE C C *** READ THE REST OF THE DATA FROM UNIT 1 (GENERAL TO MLEPCM ) *** C *** STORE IT IN THE APPROPRIATE UI AND UR LOCATIONS *** C IICDAT = IICDAT - 1 IRCDAT = IRCDAT - 1 DO 640 IOBS = 1, NOBS IF (ICSET.EQ.0) THEN READ(2,*) UI(IICH), UI(INALT) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH 570 FORMAT(1X,' CHOICE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE INDEX: ',/,5X,I3) WRITE(IOUNIT,580) 580 FORMAT(' *** PROGRAM TERMINATED... ***') STOP ENDIF ITST = UI(INALT) IF ((ITST.LE.1).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,590) IOBS,ITST 590 FORMAT(1X,' CHOICE SET SIZE ERROR IN OBS. NO. ', 1 I4,/,1X,' CHOICE SET SIZE: ',/,5X,I3) WRITE(IOUNIT,580) STOP ENDIF ELSE READ(2,*) UI(IICH) ICH = UI(IICH) IF ((ICH.LE.0).OR.(ICH.GT.NALT)) THEN WRITE(IOUNIT,570) IOBS, ICH WRITE(IOUNIT,580) STOP ENDIF UI(INALT) = ICSET ENDIF C IF (NIVAR.EQ.0) THEN READ(2,*) UI(IIIV), (UI(IICDAT+K),K=1,UI(IIIV)) ENDIF IF (NIVAR.GT.0) THEN READ(2,*) (UI(IICDAT+K),K=1,NIVAR) UI(IIIV) = NIVAR ENDIF C C *** MNP CODE: CHECK INTEGER VALUES FOR CORRECTNESS *** C IF (NIVAR.GE.0) THEN DO 610 I = 1, UI(IIIV) ITST = UI(IICDAT+I) IF ((ITST.LE.0).OR.(ITST.GT.NALT)) THEN WRITE(IOUNIT,600) IOBS,(UI(IICDAT+K),K=1,UI(IIIV)) 600 FORMAT(1X,' CHOICE SET INDEX ERROR IN OBS. NO. ', 1 I4,/,1X,' INTEGER VALUES: ',/,5X,20I3) WRITE(IOUNIT,580) STOP ENDIF 610 CONTINUE IICDAT = IICDAT + UI(IIIV) ENDIF C IF (IICDAT.GT.LUI) THEN WRITE(IOUNIT,620) 620 FORMAT(/,' *** STORAGE CAPACITY OF UI EXCEEDED ***') STOP ENDIF C IF (WEIGHT.EQ.1) THEN READ(2,*) UR(IRW) ELSE UR(IRW) = ONE ENDIF IF (ICSET.GT.1) MKTSHR(ICH) = MKTSHR(ICH) + UR(IRW) RLL0 = RLL0 + UR(IRW)*LOG(REAL(UI(INALT))) C IF (NRVAR.EQ.0) THEN READ(2,*) UI(IIRV), (UR(IRCDAT+K),K=1,UI(IIRV)) IRCDAT = IRCDAT + UI(IIRV) ENDIF IF (NRVAR.GT.0) THEN READ(2,*) (UR(IRCDAT+K),K=1,NRVAR) UI(IIRV) = NRVAR IRCDAT = IRCDAT + NRVAR ENDIF IF (IRCDAT.GT.LUR) THEN WRITE(IOUNIT,630) 630 FORMAT(/,' *** STORAGE CAPACITY OF UR EXCEEDED ***') STOP ENDIF IICH = IICH + 1 INALT = INALT + 1 IIIV = IIIV + 1 IIRV = IIRV + 1 IRW = IRW + 1 640 CONTINUE CLOSE(2) C CALL IVSET(1, IV, LIV, LV, V) C C *** SET REGRESSION DIAGNOSTIC CONSTANTS IV(83) = NFIX IV(84) = LOO IV(85) = IV85 IV(86) = IV86 IV(87) = IV87 IV(88) = 0 IV(89) = 0 IV(90) = IV90 C C IV(RDREQ) = 1 + 2*RDR IV(57) = 1 + 2*RDR C C IV(COVPRT) = 3 IV(14) = 5 C C SET IV(COVREQ) IF (COVTYP.EQ.1) IV(15) = -2 IF (COVTYP.EQ.2) IV(15) = 3 C C-------------------------------------------------------------------- C THE FOLLOWING COMMENTED-OUT CODE COULD BE USED TO ALTER C CONVERGENCE TOLERANCES: C (EXAMPLE: CALCULATE TOLERANCES AS THOUGH MACHEP WERE THE C SQUARE ROOT OF THE ACTUAL MACHEP) C MACHEP = SQRT(ETA0) C MEPCRT = MACHEP *** (ONE/THREE) C V(RFCTOL) = MAX(1.E-10, MEPCRT**2) C V(SCTOL) = V(RFCTOL) C V(XCTOL) = SQRT(MACHEP) C C WRITE(IOUNIT,650) V(RFCTOL), V(XCTOL) C650 FORMAT(//,' Relative F-Convergence tolerance: ',E13.6,/, C 1 ' Relative X-Convergence tolerance: ',E13.6,//) C-------------------------------------------------------------------- C IF (IV(1).NE.12) THEN WRITE(IOUNIT,*) ' There was a problem with calling IVSET' STOP ENDIF C C *** SET MODE TO FIXED, UNIT SCALING IN OPTIMIZATION *** C *** IV(DYTYPE) = IV(16) = 0. V(DINIT) = V(38) = 1. *** IV(16) = 0 V(38) = ONE C *** THERE ARE NO "NUISANCE PARAMETERS" IN THIS IMPLEMENTATION *** NPS = NPAR C C *** ALLOCATE STORAGE AND OPTIMIZE C CALL GLGB(NOBS, NPAR, NPS, X, B, PCMRHO, RHOI, RHOR, IV, LIV, 1 LV, V, PCMRJ, UI, UR, MECDF) C-------------------------------------------------------------------- RLLR = TWO*(RLL0 - V(10)) WRITE(IOUNIT,660) NOBS, -V(10), -RLL0, RLLR 660 FORMAT(/,' NUMBER OF OBSERVATIONS (NOBS) = ',I4,//, 1 ' LOG-LIKELIHOOD L(EST) = ',E13.6,/, 1 ' LOG-LIKELIHOOD L(0) = ',E13.6,/, 1 ' -2[L(0) - L(EST)]: = ',E13.6,/) C IF (WEIGHT.EQ.0) THEN RHOSQR = ONE - V(10)/RLL0 RSQHAT = ONE - (V(10)+NPAR)/RLL0 WRITE(IOUNIT,670) RHOSQR, RSQHAT 670 FORMAT(' 1 - L(EST)/L(0): = ',E13.6,/, 1 ' 1 - (L(EST)-NPAR)/L(0) = ',E13.6,/) ELSE WRITE(IOUNIT, 680) 680 FORMAT(' WEIGHTS USED: RHO-SQUARES NOT REPORTED.',/) ENDIF IF (ICSET.GT.1) THEN WRITE(IOUNIT,690) 690 FORMAT(' (FIXED CHOICE SET SIZE)',//, 1 ' AGGREGATE CHOICES AND MARKET SHARES: ') IF (WEIGHT.EQ.1) WRITE(IOUNIT,700) 700 FORMAT(' (WEIGHTED)') RLLC = ZERO RNOBS = NOBS DO 720 I = 1, ICSET RNI = MKTSHR(I) RFI = RNI/RNOBS IF (RFI.GT.ZERO) RLLC = RLLC + RNI*LOG(RFI) WRITE(IOUNIT,710) I, MKTSHR(I), RFI 710 FORMAT(1X,I3,2X,F10.3,2X,F6.4) 720 CONTINUE RLLR = TWO * (-RLLC - V(10)) WRITE(IOUNIT, 730) RLLC, RLLR 730 FORMAT(/,' STATISTICS FOR CONSTANTS-ONLY MODEL:',/, 1 ' LOG-LIKELIHOOD L(C) = ',E13.6,/, 1 ' -2[L(C) - L(EST)]: = ',E13.6,/) ENDIF C IF (IPRNT.EQ.1) 1 CALL FPRINT(NOBS, NPAR, X, NF, UI, UR, MECDF) C WRITE(IOUNIT,740) 740 FORMAT(//,' OUTPUT FOR CONVENIENT RESTART:') DO 760 I = 1, NPAR WRITE(IOUNIT,540) VNAME(I) WRITE(IOUNIT,750) X(I), B(1,I), B(2,I) 750 FORMAT(1X,3(1X,E13.6)) 760 CONTINUE C *** LAST LINE OF MLMNP FOLLOWS *** END //GO.SYSIN DD smlmnpb.f cat >smnpsubs.f <<'//GO.SYSIN DD smnpsubs.f' SUBROUTINE CALCPR(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB, IUSER, RUSER, MNPCDF) C C *** THIS SUBROUTINE CALCULATES A PROBABILITY FOR THE MODEL AND *** C *** DATA GIVEN. FOR MULTINOMIAL PROBIT SOME ADDITIONAL STORAGE *** C *** CUSTOMIZATION IS REQUIRED. THIS APPROACH CAN BE *** C *** USED FOR OTHER CHOICE MODELS, WITH APPROPRIATE MODIFICATIONS *** C *** TO THE ARRAYS USED BELOW. *** C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER NPAR, IERR, ICH, IALT, II, ICDAT(*), IR, IUSER(*) REAL X(NPAR), RCDAT(*), PROB, RUSER(*) EXTERNAL MNPCDF C C *** CALCPR PARAMETER USAGE *** C C IALT.... NUMBER OF CHOICES AVAILABLE IN THE CHOICE SET. C ICDAT... VECTOR OF INTEGER DATA VALUES. C ICH..... INTEGER INDICATING THE CHOICE. 1 <= ICH <= IALT. C IERR.... INTEGER FOR PASSING ERROR INFORMATION. C IN THIS ROUTINE, IF IERR = 1 ON RETURN THEN THERE WERE C NO PROBLEMS. C IF IERR = 0 ON RETURN, THEN THE PROBABILITY COULD NOT C BE COMPUTED USING THE CURRENT PARAMETERS IN X. C II...... NUMBER OF INTEGER VALUES STORED IN VECTIR ICDAT. C IUSER... MODEL-RELATED INTEGER VALUES USED BY CALCPR. CONTAINS C ARRAY POINTERS TO MANAGE DATA STORAGE, AND OTHER C PARAMETERS. C MNPCDF.. SUBROUTINE WHICH CALCULATES THE CDF OF A MULTIVARIATE C NORMAL DISTRIBUTION. C NPAR.... NUMBER OF PARAMETERS IN VECTOR X. C PROB.... ON RETURN, CHOICE PROBABILITY COMPUTED USING PARAMETERS IN C X AND DATA IN ICDAT AND RCDAT. C RCDAT... VECTOR OF REAL DATA VALUES. C RUSER... MODEL-RELATED REAL VALUES USED BY CALCPR. CAN CONTAIN C USEFUL PARAMETERS, AND ALSO EXTRA WORK STORAGE. C EXTERNAL CALCP1 INTEGER ISIGU, IW, NALT, NW C ISIGU = IUSER(16) IW = IUSER(15) NALT = MAX(1,IUSER(6)) NW = MAX(1, IUSER(7)) CALL CALCP1(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB, IUSER, RUSER, NALT, RUSER(ISIGU), 2 NW, RUSER(IW), MNPCDF) C *** LAST LINE OF CALCPR FOLLOWS *** END SUBROUTINE CALCP1(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB, IUSER, RUSER, NALT, SIGU, NW, W, MNPCDF) C C *** THIS SUBROUTINE CALCULATES A PROBABILITY FOR THE MNP MODEL *** C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER NPAR, IERR, ICH, IALT, II, ICDAT(*), IR, IUSER(*), NALT, 1 NATTR, NW REAL X(NPAR), RCDAT(*), PROB, RUSER(*), 1 SIGU(NALT,NALT), W(NW,NALT) EXTERNAL MNPCDF C C *** CALCP1 PARAMETER USAGE *** C C IALT.... NUMBER OF CHOICES AVAILABLE IN THE CHOICE SET. C ICDAT... VECTOR OF INTEGER DATA VALUES. C IN THIS SUBROUTINE, ICDAT STORES INTEGER INDEXES WHICH C DEFINE WHICH OF THE NOMINAL ALTERNATIVES ARE AVAILABLE C IN THE CHOICE SET. (THIS IS FOR THE CASE WHEN THERE C ARE NALT NOMINAL CHOICE ALTERNATIVES, BUT NOT ALL OF C THEM NECESSARILY APPEAR IN EVERY SUBSET. IF ALL NALT C ALTERNATIVES APPEAR IN ALL SUBSETS, THEN ICSET = NALT >0 C SHOULD BE USED WITH IDUM = 1. C ICH..... INTEGER INDICATING THE CHOICE. 1 <= ICH <= IALT. C ICOV.... INDICATOR FOR TYPE OF ALTERNATIVE-SPECIFIC ERRORS, C = 0 FOR IID ERRORS, = 1 FOR CORRELATED ERRORS. C IF ICSET .NE. 0, THEN THE SAME CORRELATION MATRIX IS C USED FOR EVERY SUBSET. OTHERWISE, INTEGER DATA SHOULD C BE USED TO IDENTIFY THE ALTERNATIVES IN EACH CHOICE SET. C (STORED IN IUSER.) C IDUM... INDICATOR FOR ALTERNATIVE-SPECIFIC DUMMIES, C = 0 FOR NO, = 1 FOR YES. IF ICSET .NE. 0, THEN C THE SAME SET OF DUMMIES IS USED FOR EACH CHOICE SET. C OTHERWISE, INTEGER DATA SHOULD BE USED TO IDENTIFY THE C ALTERNATIVES IN EACH CHOICE SET (SEE NALT BELOW). C (STORED IN IUSER). C IERR.... INTEGER FOR PASSING ERROR INFORMATION. C IN THIS ROUTINE, IF IERR = 1 ON RETURN THEN THERE WERE C NO PROBLEMS. C IF IERR = 0 ON RETURN, THEN THE PROBABILITY COULD NOT C BE COMPUTED USING THE CURRENT PARAMETERS IN X. C II...... NUMBER OF INTEGER VALUES STORED IN VECTIR ICDAT. C IUSER... MODEL-RELATED INTEGER VALUES USED BY CALCPR. THE FIRST C PORTION OF IUSER CONTAINS SUCH THINGS AS ARRAY POINTERS. C IUSER ALSO CONTAINS STORED VALUES OF NATTR, IDUM, ETC. C IR...... NUMBER OF REAL VALUES STORED IN VECTOR IRDAT. C ITASTE.. INDICATOR FOR TASTE VARIATION, C = 0 FOR NO TASTE VARIATION, = 1 FOR UNCORRELATED TASTE C VARIATION, = 2 FOR CORRELATED TASTE VARIATION. C (STORED IN IUSER.) C NPAR.... NUMBER OF PARAMETERS IN VECTOR X. C PROB.... ON RETURN, CHOICE PROBABILITY COMPUTED USING PARAMETERS IN C X AND DATA IN ICDAT AND RCDAT. C RCDAT... VECTOR OF REAL DATA VALUES. C IN THIS SUBROUTINE, THE NUMBER OF DATA VALUES SHOULD C BE = IALT * NATTR SO THAT THE "GENERIC" PART OF THE C SCALE VALUE V MAY BE COMPUTED. C NALT.... TOTAL NUMBER OF NOMINAL CHOICE ALTERNATIVES (IF APPLICABLE). C IF ICSET .NE. 0 AND IDUM = 1 OR ICOV = 1 (OR BOTH), THEN C NALT SHOULD BE EQUAL TO ICSET. C OTHERWISE, NALT SHOULD BE > 0 IF EITHER IDUM OR ICOV C (OR BOTH) ARE > 0, AND ICDAT SHOULD BE USED TO PASS C INDEX INFORMATION (SEE ICDAT ABOVE). C NATTR... NUMBER OF ATTRIBUTES (I.E., REAL DATA VARS.) PER ALTERNATIVE. C NW...... NUMBER OF ROWS IN THE WORK-ARRAY W. C RUSER... MODEL-RELATED REAL VALUES USED BY CALCPR. FOR THIS MODEL, C IT CONTAINS A CONSTANT FOR THE COVARIANCE MATRIX SCALE, C AND INFORMATION USED FOR COMPUTING STEP SIZES IN FINITE- C DIFFERENCE CALCULATIONS. C SIGU.... MATRIX CONTAINING THE "UNPACKED" THE FULL COVARIANCE MATRIX C FOR ALL NALT ALTERNATIVE-SPECIFIC ERROR TERMS. THE C MATRIX IS OF DIMENSION 2 TO FACILITATE CODING. THE C NORMALIZATION USED LEAVES A ROW OF ZEROS IN THE LAST C (NALT) ROW. IT IS COMPUTED BEFORE THE CALL TO MINIMIZE C WORK WHEN CALLS ARE TO BE REPEATED. C W....... ARRAY CONTAINING WORKSPACE FOR COVARIANCE COMPUTATIONS. C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C C EXTERNAL L7VML, V7SCP C INTEGER I, IALTM1, ICOL, ICOV, ICSET, ID, IDUM, IFAULT, IIR, 1 IOUNIT, IPCOEF, IPDUM, IPT, IPTAST, IROW, ISCALE, ISZ, 2 ITASTE, IX, J, JP, K, KP C INTEGER MAXALT, MAXAM1, LR PARAMETER (MAXALT=20, MAXAM1=MAXALT-1, LR=MAXAM1*(MAXAM1-1)/2) C REAL SCALE, SII REAL V(MAXALT), SIGMA(MAXALT,MAXALT) REAL Z(MAXAM1), SIGZ(MAXAM1,MAXAM1), R(LR) C REAL ZERO PARAMETER (ZERO=0.E0) C C SET UP V AND SIGMA MATRIX FOR MNP SPECIFICATION. C C ALTERNATIVE-SPECIFIC DUMMIES: C IALTM1 = IALT - 1 IDUM = IUSER(8) IF (IDUM.NE.0) THEN IPDUM = IUSER(12) C CASE 1: ICSET = 0. ICSET = IUSER(5) IF (ICSET.EQ.0) THEN DO 10 I = 1, IALT IX = ICDAT(I) IF (IX.NE.NALT) THEN V(I) = X(IX+IPDUM) ELSE V(I) = ZERO ENDIF 10 CONTINUE ELSE C CASE 2: ICSET.NE.0 V(IALT) = ZERO DO 20 I = 1, IALTM1 V(I) = X(I+IPDUM) 20 CONTINUE ENDIF ELSE CALL V7SCP(IALT, V, ZERO) ENDIF C C BETA COEFFICIENTS: C NATTR = IUSER(7) IF (NATTR.NE.0) THEN IPCOEF = IUSER(11) ID = 0 DO 30 I = 1, IALT DO 30 K = 1, NATTR ID = ID + 1 V(I) = V(I) + X(IPCOEF+K)*RCDAT(ID) 30 CONTINUE ENDIF C C ALTERNATIVE-SPECIFIC ERRORS: C ICOV = IUSER(9) IF (ICOV.NE.0) THEN ICSET = IUSER(5) IF (ICSET.EQ.0) THEN DO 40 I = 1, IALT IROW = ICDAT(I) DO 40 J = 1, I ICOL = ICDAT(J) IF (ICOL.LE.IROW) THEN SIGMA(I,J) = SIGU(IROW,ICOL) ELSE SIGMA(I,J) = SIGU(ICOL,IROW) ENDIF 40 CONTINUE ELSE DO 50 I = 1, IALT DO 50 J = 1, I SIGMA(I,J) = SIGU(I,J) 50 CONTINUE ENDIF ELSE ISCALE = IUSER(18) SCALE = RUSER(ISCALE) DO 60 I = 1, IALT DO 60 J = 1, I IF (I.EQ.J) THEN SIGMA(I,J) = SCALE ELSE SIGMA(I,J) = ZERO ENDIF 60 CONTINUE ENDIF C C TASTE VARIATION: C ITASTE = IUSER(10) IF (ITASTE.EQ.1) THEN C UNCORRELATED TASTE VARIATION C SET UP W MATRIX: ID = 0 IPTAST = IUSER(14) DO 70 J = 1, IALT IPT = IPTAST DO 70 K = 1, NATTR IPT = IPT + 1 ID = ID + 1 W(K,J) = X(IPT) * RCDAT(ID) 70 CONTINUE ENDIF C IF (ITASTE.EQ.2) THEN C CORRELATED TASTE VARIATION C SET UP W MATRIX: ID = 1 IPTAST = IUSER(14) + 1 DO 80 J = 1, IALT CALL L7VML(NATTR, W(1,J), X(IPTAST), RCDAT(ID)) ID = ID + NATTR 80 CONTINUE ENDIF IF (ITASTE.NE.0) THEN C TASTE VARIATION C ADD W(**T)W TO SIGMA: DO 100 I = 1, IALT DO 100 J = 1, I DO 90 K = 1, NATTR SIGMA(I,J) = SIGMA(I,J) + W(K,I)*W(K,J) 90 CONTINUE 100 CONTINUE ENDIF C C SYMMETRIZE SIGMA (MAY NOT BE NECESSARY???) C C IF ((ICOV.NE.0).OR.(ITASTE.NE.0)) THEN DO 110 I = 1, IALT DO 110 J = 1, I SIGMA(J,I) = SIGMA(I,J) 110 CONTINUE C ENDIF C C LOWER DIMENSION VIA STANDARD TRANSFORMATION C (REF. PAGE 43 OF DAGANZO OR BUNCH(1991)) ISZ = 0 SII = SIGMA(ICH,ICH) DO 130 JP = 1, IALT IF (JP.LT.ICH) THEN J = JP ELSE J = JP - 1 ENDIF IF (JP.NE.ICH) THEN Z(J) = V(JP)-V(ICH) DO 120 KP = 1, JP IF (KP.LT.ICH) THEN K = KP ELSE K = KP - 1 ENDIF IF(KP.NE.ICH) THEN ISZ = ISZ + 1 SIGZ(J,K)=SIGMA(JP,KP)-SIGMA(ICH,KP)-SIGMA(ICH,JP)+SII ENDIF 120 CONTINUE ENDIF 130 CONTINUE C IIR = 0 DO 150 J = 1, IALTM1 IF (SIGZ(J,J).LE.ZERO) THEN IERR = 0 RETURN ENDIF SIGZ(J,J) = SQRT(SIGZ(J,J)) Z(J) = Z(J)/SIGZ(J,J) DO 140 K = 1, J-1 IIR = IIR + 1 R(IIR) = SIGZ(J,K)/SIGZ(J,J)/SIGZ(K,K) 140 CONTINUE 150 CONTINUE C IERR = 1 CALL MNPCDF(IALTM1, Z, R, PROB, IFAULT) IF (IFAULT.NE.0) then IERR = 0 IOUNIT = IUSER(3) WRITE(IOUNIT,*) ' Problem evaluating mnpcdf' ENDIF C *** LAST LINE OF CALCP1 FOLLOWS *** END SUBROUTINE CALCDP(NPAR, X, IERR, ICH, IALT, II, ICDAT, IR, RCDAT, 1 PROB0, DP, IUSER, RUSER, MNPCDF) C C *** THIS SUBROUTINE CALCULATES FINITE-DIFFERENCE DERIVATIVES FOR *** C *** CHOICE PROBABILITIES. THIS VERSION ASSUMES THAT THE CALCPR *** C *** BEING CALLED IS THE ONE FOR MULTINOMIAL PROBIT. HOWEVER, *** C *** THE CHANGES REQUIRED FOR OTHER MODELS SHOULD BE MINOR. *** C *** NOTE: THIS SUBROUTINE REQUIRES S7GRD, AND THE ARRAYS ALPHA *** C *** AND D SHOULD HAVE THE SAME DIMENSION AS X. *** C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++ C INTEGER NPAR, IERR, ICH, IALT, II, ICDAT(*), IR, IUSER(*) REAL X(NPAR), RCDAT(*), PROB0, DP(NPAR), RUSER(*) EXTERNAL MNPCDF C EXTERNAL CALCPR, S7GRD, V7SCP INTEGER I, ICOV, IETA0, IPCOV, IPP, IPU, IPUP, IRC, ISCALE, ISIGP, 1 ISIGU, J, NALT, NALTM1, NFC REAL ETA, ETA0, PROB, SCALE, XTEMP C INTEGER LX REAL ONE, ZERO PARAMETER (ZERO=0.E0, ONE=1.E0, LX=60) C REAL ALPHA(LX), D(LX), WRK(6) C C *** PARAMETER USAGE *** C C SEE CALCPR AND CALCP1 C C *** BODY *** C IERR = 1 ICOV = IUSER(9) NALT = IUSER(6) NALTM1 = NALT - 1 ISCALE = IUSER(18) SCALE = RUSER(ISCALE) IETA0 = IUSER(17) ETA0 = RUSER(IETA0) C DO 10 I = 1, NPAR ALPHA(I) = ONE D(I) = ONE 10 CONTINUE C ETA = ETA0 C ETA = ETA0/PROB IRC = 0 C PROB = PROB0 20 CONTINUE CALL S7GRD(ALPHA, D, ETA, PROB, DP, IRC, 1 NPAR, WRK, X) IF (IRC.EQ.0) GO TO 40 C IF ICOV.NE.0, SET UP AN UNPACKED SIGMA MATRIX IF (ICOV.NE.0) THEN C SQUARE THE CHOLESKY FACTOR TO GET (PACKED) SIGMA: IPCOV = IUSER(13) XTEMP = X(IPCOV) X(IPCOV) = SCALE ISIGP = IUSER(15) CALL L7SQR(NALTM1, RUSER(ISIGP), X(IPCOV)) X(IPCOV) = XTEMP C "UNPACK" FOR EASIER ACCESS IN CALCPR: IPP = ISIGP - 1 ISIGU = IUSER(16) CALL V7SCP(NALT*NALT, RUSER(ISIGU), ZERO) IPUP = ISIGU - 1 DO 30 I = 1, NALTM1 IPU = I + IPUP DO 30 J = 1, I IPP = IPP + 1 RUSER(IPU) = RUSER(IPP) IPU = IPU + NALT 30 CONTINUE ENDIF CALL CALCPR(NPAR, X, NFC, ICH, IALT, II, ICDAT, 1 IR, RCDAT, PROB, IUSER, RUSER, MNPCDF) IF (NFC.EQ.0) THEN IERR = 0 RETURN ENDIF GO TO 20 40 CONTINUE C C *** LAST LINE OF CALCDP FOLLOWS *** END SUBROUTINE S7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X) C C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME *** C *** THIS IS SGRAD2 FROM TOMS ALGORITHM 611. C C *** PARAMETERS *** C INTEGER IRC, N REAL ALPHA(N), D(N), ETA0, FX, G(N), W(6), X(N) C C....................................................................... C C *** PURPOSE *** C C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER- C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY C REVERSE COMMUNICATION. C C *** PARAMETER DESCRIPTION *** C C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X). C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,N, ARE IN C COMPARABLE UNITS. C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE... C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE C ABS(E) .LE. ETA0. C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL C VALUE, THE ONE IT HAD WHEN S7GRD WAS LAST CALLED WITH C IRC = 0. C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE C PREVIOUS ITERATE. WHEN S7GRD RETURNS WITH IRC = 0, G IS C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE C GRADIENT AT X. C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON S7GRD, C THE CALLER MUST SET IRC TO 0. WHENEVER S7GRD RETURNS A C NONZERO VALUE FOR IRC, IT HAS PERTURBED SOME COMPONENT OF C X... THE CALLER SHOULD EVALUATE F(X) AND CALL S7GRD C AGAIN WITH FX = F(X). C N IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F C DEPENDS. C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE C (THE ONE IT HAD WHEN S7GRD WAS LAST CALLED WITH IRC = 0) C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION. C W I/O WORK VECTOR OF LENGTH 6 IN WHICH S7GRD SAVES CERTAIN C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A C PERTURBED X. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION). C C *** ALGORITHM NOTES *** C C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1) C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G). C C *** REFERENCES *** C C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES, C J. ASSOC. COMPUT. MACH. 14, PP. 72-83. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980). C C *** GENERAL *** C C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND C MCS-7906671. C C....................................................................... C C ***** EXTERNAL FUNCTION ***** C EXTERNAL R7MDC REAL R7MDC C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS. C C ***** LOCAL VARIABLES ***** C INTEGER FH, FX0, HSAVE, I, XISAVE REAL AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR, 1 DISCON, ETA, GI, H, HMIN REAL C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002, 1 THREE, TWO, ZERO C PARAMETER (C2000=2.0E+3, FOUR=4.0E+0, HMAX0=0.02E+0, HMIN0=5.0E+1, 1 ONE=1.0E+0, P002=0.002E+0, THREE=3.0E+0, 2 TWO=2.0E+0, ZERO=0.0E+0) PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6) C C--------------------------------- BODY ------------------------------ C IF (IRC) 50, 10, 110 C C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS *** C C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE C SQUARE-ROOT OF MACHEP. C 10 W(1) = R7MDC(3) W(2) = SQRT(W(1)) C W(FX0) = FX C C *** INCREMENT I AND START COMPUTING G(I) *** C 20 I = ABS(IRC) + 1 IF (I .GT. N) GO TO 120 IRC = I AFX = ABS(W(FX0)) MACHEP = W(1) H0 = W(2) HMIN = HMIN0 * MACHEP W(XISAVE) = X(I) AXI = ABS(X(I)) AXIBAR = MAX(AXI, ONE/D(I)) GI = G(I) AGI = ABS(GI) ETA = ABS(ETA0) IF (AFX .GT. ZERO) ETA = MAX(ETA, AGI*AXI*MACHEP/AFX) ALPHAI = ALPHA(I) IF (ALPHAI .EQ. ZERO) GO TO 80 IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 90 AFXETA = AFX*ETA AAI = ABS(ALPHAI) C C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE. C IF (GI**2 .LE. AFXETA*AAI) GO TO 30 H = TWO* SQRT(AFXETA/AAI) H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI)) GO TO 40 30 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE) H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI)) C C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL *** C 40 H = MAX(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 70 C C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE. C DISCON = C2000*AFXETA H = DISCON/(AGI + SQRT(GI**2 + AAI*DISCON)) C C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG *** C H = MAX(H, HMIN*AXIBAR) IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE) C C *** COMPUTE CENTRAL DIFFERENCE *** C IRC = -I GO TO 100 C 50 H = -W(HSAVE) I = ABS(IRC) IF (H .GT. ZERO) GO TO 60 W(FH) = FX GO TO 100 C 60 G(I) = (W(FH) - FX) / (TWO * H) X(I) = W(XISAVE) GO TO 20 C C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES *** C 70 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR IF (ALPHAI*GI .LT. ZERO) H = -H GO TO 100 80 H = AXIBAR GO TO 100 90 H = H0 * AXIBAR C 100 X(I) = W(XISAVE) + H W(HSAVE) = H GO TO 999 C C *** COMPUTE ACTUAL FORWARD DIFFERENCE *** C 110 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 120 FX = W(FX0) IRC = 0 C 999 RETURN C *** LAST CARD OF S7GRD FOLLOWS *** END SUBROUTINE PCMRJ(NOBS, NPAR, X, NF, NEED, R, RP, UI, UR, UF) INTEGER NOBS, NPAR, NF, NEED(2), UI(*) REAL X(NPAR), R(NOBS), RP(NPAR,NOBS), UR(*) EXTERNAL UF C EXTERNAL PCMRJ1 C INTEGER ICP, IICDAT, IICH, IIIV, IIRV, IIU, INALT, IRCDAT, IRU C C *** BODY *** C IIU = UI(1) IICH = UI(2) INALT = UI(3) IIIV = UI(4) IIRV = UI(5) IICDAT = UI(6) C IRU = UI(7) ICP = UI(8) C IRW = UI(9) IRCDAT = UI(10) C CALL PCMRJ1(NOBS, NPAR, X, NF, NEED, R, RP, 1 UI(IIU), UI(IICH), UI(INALT), UI(IIIV), UI(IIRV), UI(IICDAT), 2 UR(IRU), UR(ICP), UR(IRCDAT), UF) 999 RETURN C *** LAST LINE OF PCMRJ FOLLOWS *** END SUBROUTINE PCMRJ1(NOBS, NPAR, X, NF, NEED, R, RP, 1 IUSER, ICHV, NALTV, IIV, IRV, ICDAT, 2 RUSER, CPROB, RCDAT, UF) C C *** THIS SUBROUTINE EXPANDS THE STORAGE IN UI AND UR TO MAKE THEM *** C *** COMPATIBLE WITH ESTIMATION OF CHOICE MODELS. *** C INTEGER NOBS, NPAR, NF, NEED(2), IUSER(*), ICHV(NOBS), 1 NALTV(NOBS), IIV(NOBS), IRV(NOBS), ICDAT(*) REAL X(NPAR), R(NOBS), RP(NPAR,NOBS), RUSER(*), 1 CPROB(NOBS,2), RCDAT(*) EXTERNAL UF C EXTERNAL CALCDP, CALCPR, L7SQR, V7SCP C INTEGER I, IALT, ICH, ICOV, IERR, II, III, IIR, IOBS, IOUNIT, 1 IPCOV, IPP, IPU, IPUP, IR, ISCALE, ISIGP, ISIGU, J, KS, 2 NALT, NALTM1, NFC REAL PROB, SCALE, XTEMP C INTEGER LX REAL ONE, ZERO PARAMETER (ZERO=0.E0, ONE=1.E0, LX=60) C C ARRAYS: C C CPROB... VECTOR FOR STORING CHOICE PROBABILITIES. CPROB(IOBS,J) C FOR J=1,2 STORES CHOICE PROBABILITIES FOR OBSERVATION C IOBS. ONE IS THE CURRENT PROBABILITY, WHILE THE OTHER C ONE IS THE PROBABILITY COMPUTED AT THE PREVIOUS TRIAL C X. THE CODE KEEPS TRACK OF WHICH IS WHICH USING THE C POINTERS STORED IN IUSER(1) AND IUSER(2). THIS IS USED C IN VARIOUS WAYS TO MAKE COMPUTATION MORE EFFICIENT. C ICHV.... VECTOR OF LENGTH NOBS. ICHV(IOBS) CONTAINS THE INDEX OF C THE CHOSEN ALTERNATIVE FOR OBSERVATION IOBS. C IIV..... VECTOR OF LENGHT NOBS. IIV(IOBS) INDICATES THE NUMBER OF C INTEGER DATA VALUES STORED IN ICDAT FOR OBSERVATION IOBS. C IRV..... VECTOR OF LENGHT NOBS. IRV(IOBS) INDICATES THE NUMBER OF C REAL DATA VALUES STORED IN RCDAT FOR OBSERVATION IOBS. C NALTV... VECTOR OF LENGHT NOBS. NALTV(IOBS) INDICATES THE NUMBER OF C CHOICES AVAILABLE FOR OBSERVATION IOBS. C C *** BODY *** C ICOV = IUSER(9) NALT = IUSER(6) NALTM1 = NALT - 1 ISCALE = IUSER(18) SCALE = RUSER(ISCALE) C IF (NEED(1).EQ.1) THEN C C *** CALCULATE RESIDUAL VECTOR *** KS = 1 IF (NEED(2).EQ.IUSER(1)) KS = 2 IUSER(KS) = NF C C IF ICOV.NE.0, SET UP AN UNPACKED SIGMA MATRIX IF (ICOV.NE.0) THEN C SQUARE THE CHOLESKY FACTOR TO GET (PACKED) SIGMA: IPCOV = IUSER(13) XTEMP = X(IPCOV) X(IPCOV) = SCALE ISIGP = IUSER(15) CALL L7SQR(NALTM1, RUSER(ISIGP), X(IPCOV)) X(IPCOV) = XTEMP C "UNPACK" FOR EASIER ACCESS IN CALCPR: IPP = ISIGP - 1 ISIGU = IUSER(16) CALL V7SCP(NALT*NALT, RUSER(ISIGU), ZERO) IPUP = ISIGU - 1 DO 10 I = 1, NALTM1 IPU = I + IPUP DO 10 J = 1, I IPP = IPP + 1 RUSER(IPU) = RUSER(IPP) IPU = IPU + NALT 10 CONTINUE ENDIF III = 1 IIR = 1 DO 20 IOBS = 1, NOBS ICH = ICHV(IOBS) IALT = NALTV(IOBS) II = IIV(IOBS) IR = IRV(IOBS) CALL CALCPR(NPAR, X, NFC, ICH, IALT, II, ICDAT(III), 1 IR, RCDAT(IIR), PROB, IUSER, RUSER, UF) IF ((PROB.LE.ZERO).OR.(PROB.GT.ONE).OR.(NFC.EQ.0)) THEN NF = 0 RETURN ENDIF R(IOBS) = PROB CPROB(IOBS,KS) = PROB III = III + II IIR = IIR + IR 20 CONTINUE ELSE C C *** CALCULATE JACOBIAN OF RESIDUAL VECTOR *** C KS = 1 IF (IUSER(1).NE.NF) KS = 2 IF (IUSER(KS).NE.NF) THEN IOUNIT = IUSER(3) WRITE(IOUNIT,*) ' PROBLEM WITH INITIAL ESTIMATE...' ENDIF C III = 1 IIR = 1 DO 30 IOBS = 1, NOBS ICH = ICHV(IOBS) IALT = NALTV(IOBS) II = IIV(IOBS) IR = IRV(IOBS) PROB = CPROB(IOBS,KS) CALL CALCDP(NPAR, X, IERR, ICH, IALT, II, ICDAT(III), 1 IR, RCDAT(IIR), PROB, RP(1,IOBS), IUSER, RUSER, UF) IF (IERR.EQ.0) THEN NF = 0 RETURN ENDIF III = III + II IIR = IIR + IR 30 CONTINUE ENDIF 999 RETURN C *** LAST LINE OF PCMRJ1 FOLLOWS *** END SUBROUTINE PCMRHO(NEED, F, NOBS, NF, XN, R, RD, UI, UR, W) INTEGER NEED(2), NOBS, NF, UI(*) REAL F, XN(*), R(*), RD(NOBS,*), UR(*), W(NOBS) C INTEGER ICP, IOBS, IOUNIT, IRW, WEIGHT, KS REAL OOR, VT C REAL NEGONE, ZERO PARAMETER (NEGONE=-1.E0, ZERO=0.E0) C C *** BODY *** C WEIGHT = UI(14) IF (NEED(1).EQ.1) THEN VT = ZERO IF (WEIGHT.EQ.0) THEN DO 10 IOBS = 1, NOBS VT = VT - LOG(R(IOBS)) 10 CONTINUE ELSE IRW = UI(9) DO 20 IOBS = 1, NOBS VT = VT - UR(IRW) * LOG(R(IOBS)) IRW = IRW + 1 20 CONTINUE ENDIF F = VT ELSE KS = 1 IF (UI(11).NE.NF) KS = 2 IF (UI(10+KS).NE.NF) THEN IOUNIT = UI(13) WRITE(IOUNIT,*) ' PROBLEM WITH INITIAL POINT...' NF = 0 RETURN ENDIF ICP = UI(8) IF (KS.EQ.2) ICP = ICP + NOBS IF (WEIGHT.EQ.0) THEN DO 30 IOBS = 1, NOBS OOR = NEGONE/UR(ICP) R(IOBS) = OOR W(IOBS) = R(IOBS) * OOR RD(IOBS,1) = W(IOBS) ICP = ICP + 1 30 CONTINUE ELSE IRW = UI(9) DO 40 IOBS = 1, NOBS OOR = NEGONE/UR(ICP) R(IOBS) = UR(IRW) * OOR W(IOBS) = R(IOBS) * OOR RD(IOBS,1) = W(IOBS) ICP = ICP + 1 IRW = IRW + 1 40 CONTINUE ENDIF ENDIF 999 RETURN C *** LAST LINE OF PCMRHO FOLLOWS *** END SUBROUTINE FPRINT(NOBS, NPAR, X, NF, UI, UR, UF) INTEGER NOBS, NPAR, NF, UI(*) REAL X(NPAR), UR(*) EXTERNAL UF C EXTERNAL FPRNT1 C INTEGER ICP, IICDAT, IICH, IIIV, IIRV, IIU, INALT, IRCDAT, IRU, 1 IRW C C *** BODY *** C IIU = UI(1) IICH = UI(2) INALT = UI(3) IIIV = UI(4) IIRV = UI(5) IICDAT = UI(6) C IRU = UI(7) ICP = UI(8) IRW = UI(9) IRCDAT = UI(10) C CALL FPRNT1(NOBS, NPAR, X, NF, 1 UI(IIU), UI(IICH), UI(INALT), UI(IIIV), UI(IIRV), UI(IICDAT), 2 UR(IRU), UR(IRCDAT), UR(IRW), UF) 999 RETURN C *** LAST LINE OF FPRINT FOLLOWS *** END SUBROUTINE FPRNT1(NOBS, NPAR, X, NF, 1 IUSER, ICHV, NALTV, IIV, IRV, ICDAT, 2 RUSER, RCDAT, WT, UF) C C *** THIS SUBROUTINE EXPANDS THE STORAGE IN UI AND UR TO MAKE THEM *** C *** COMPATIBLE WITH ESTIMATION OF CHOICE MODELS. *** C *** SEE PCMRJ1 DOCUMENTATION ON ARRAYS. *** C INTEGER NOBS, NPAR, NF, IUSER(*), ICHV(NOBS), NALTV(NOBS), 1 IIV(NOBS), IRV(NOBS), ICDAT(*) REAL X(NPAR), RUSER(*), RCDAT(*), WT(NOBS) EXTERNAL UF C EXTERNAL CALCPR, L7SQR, V7SCP C INTEGER I, IALT, ICH, ICOV, ICSET, II, III, IIR, IOBS, IOUNIT, 1 IPCOV, IPP, IPU, IPUP, IR, ISCALE, ISIGP, ISIGU, J, NALT, 2 NALTM1, NFC REAL FPROB(20), PROB, SCALE, XTEMP C INTEGER LX REAL ONE, ZERO PARAMETER (ZERO=0.E0, ONE=1.E0, LX=60) C C *** BODY *** C ICOV = IUSER(9) ICSET = IUSER(5) IOUNIT = IUSER(3) NALT = IUSER(6) NALTM1 = NALT - 1 ISCALE = IUSER(18) SCALE = RUSER(ISCALE) C WRITE(IOUNIT, 10) 10 FORMAT(//,' FINAL CHOICE SET PROBABILITIES: ',/) C C IF ICOV.NE.0, SET UP AN UNPACKED SIGMA MATRIX IF (ICOV.NE.0) THEN C SQUARE THE CHOLESKY FACTOR TO GET (PACKED) SIGMA: IPCOV = IUSER(13) XTEMP = X(IPCOV) X(IPCOV) = SCALE ISIGP = IUSER(15) CALL L7SQR(NALTM1, RUSER(ISIGP), X(IPCOV)) X(IPCOV) = XTEMP C "UNPACK" FOR EASIER ACCESS IN CALCPR: IPP = ISIGP - 1 ISIGU = IUSER(16) CALL V7SCP(NALT*NALT, RUSER(ISIGU), ZERO) IPUP = ISIGU - 1 DO 20 I = 1, NALTM1 IPU = I + IPUP DO 20 J = 1, I IPP = IPP + 1 RUSER(IPU) = RUSER(IPP) IPU = IPU + NALT 20 CONTINUE ENDIF III = 1 IIR = 1 DO 90 IOBS = 1, NOBS ICH = ICHV(IOBS) IALT = NALTV(IOBS) II = IIV(IOBS) IR = IRV(IOBS) DO 30 I = 1, IALT CALL CALCPR(NPAR, X, NFC, I, IALT, II, ICDAT(III), 1 IR, RCDAT(IIR), PROB, IUSER, RUSER, UF) FPROB(I) = PROB 30 CONTINUE WRITE(IOUNIT, 40) IOBS 40 FORMAT(/,' IOBS: ',I4) IF (ICSET.EQ.0) WRITE(IOUNIT,50) (ICDAT(I),I=1,IALT) 50 FORMAT(' CHOICE SET: ',20I3) WRITE(IOUNIT, 60) IALT, ICH, WT(IOBS) 60 FORMAT(' NO. OF ALTS: ',I2,' ICH: ',I2, 1 ' WT: ',F7.3) WRITE(IOUNIT, 70) (FPROB(I),I=1,IALT) 70 FORMAT(' PROBS: ',8F7.4,/,18X,8F7.4,/,18X,4F7.4) WRITE(IOUNIT, 80) FPROB(ICH) 80 FORMAT(' PROB(ICH): ',F7.4) III = III + II IIR = IIR + IR 90 CONTINUE C 999 RETURN C *** LAST LINE OF FPRNT1 FOLLOWS *** END //GO.SYSIN DD smnpsubs.f cat >madsen.sgi <<'//GO.SYSIN DD madsen.sgi' DGLG ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP NPRELDF 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 .98E+00 2 4 .443E+01 .88E+00 .95E+00 .2E+00 G .0E+00 .6E+01 .95E+00 3 6 .128E+01 .71E+00 .67E+00 .3E+00 G-S .0E+00 .5E+01 .67E+00 4 7 .593E+00 .54E+00 .59E+00 .1E+01 S .0E+00 .3E+01 .59E+00 5 8 .415E+00 .30E+00 .24E+00 .1E+00 S .0E+00 .5E+00 .24E+00 6 9 .390E+00 .60E-01 .87E-01 .7E-01 G .0E+00 .3E+00 .87E-01 7 10 .387E+00 .89E-02 .89E-02 .4E-01 S .0E+00 .1E+00 .89E-02 8 11 .387E+00 .24E-04 .23E-04 .2E-02 S .0E+00 .5E-02 .23E-04 9 12 .387E+00 .30E-07 .30E-07 .8E-04 S .0E+00 .2E-03 .30E-07 10 13 .387E+00 .36E-11 .48E-11 .1E-05 S .0E+00 .2E-05 .48E-11 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .386600E+00 RELDX .105E-05 FUNC. EVALS 13 GRAD. EVALS 11 PRELDF .484E-11 NPRELDF .484E-11 I FINAL X(I) D(I) G(I) 1 -.155437E+00 .124E+01 .600E-06 2 .694564E+00 .146E+01 .124E-06 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .64 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .649 ROW 2 -.265 .575 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .735 .565E-01 .119 DGLG NEEDED LIV .GE. ,I3,12H AND LV .GE. 92 DGLG NEEDED LIV .GE. ,I3,12H AND LV .GE. 173 DGLF ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .443E+01 .88E+00 .95E+00 .2E+00 G .0E+00 .6E+01 3 6 .128E+01 .71E+00 .67E+00 .3E+00 G-S .0E+00 .5E+01 4 7 .593E+00 .54E+00 .59E+00 .1E+01 S .0E+00 .3E+01 5 8 .415E+00 .30E+00 .24E+00 .1E+00 S .0E+00 .5E+00 6 9 .390E+00 .60E-01 .87E-01 .7E-01 G .0E+00 .3E+00 7 10 .387E+00 .89E-02 .89E-02 .4E-01 S .0E+00 .1E+00 8 11 .387E+00 .24E-04 .23E-04 .2E-02 S .0E+00 .5E-02 9 12 .387E+00 .30E-07 .30E-07 .8E-04 S .0E+00 .2E-03 10 13 .387E+00 .36E-11 .48E-11 .1E-05 S .0E+00 .2E-05 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .386600E+00 RELDX .105E-05 FUNC. EVALS 13 GRAD. EVALS 24 PRELDF .484E-11 NPRELDF .484E-11 I FINAL X(I) D(I) G(I) 1 -.155437E+00 .124E+01 .594E-06 2 .694564E+00 .146E+01 .117E-06 6 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .64 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .649 ROW 2 -.265 .575 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .735 .565E-01 .119 DGLF ON PROBLEM MADSEN AGAIN... NONDEFAULT VALUES.... LMAX0..... V(35) = .1000000E+00 I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 6 .521E+02 .38E+00 .41E+00 .4E-01 G .6E+01 .2E+01 2 7 .783E+01 .85E+00 .95E+00 .1E+00 G .3E+00 .6E+01 3 9 .215E+01 .72E+00 .78E+00 .5E+00 G-S .0E+00 .9E+01 4 10 .103E+01 .52E+00 .96E+00 .5E+00 G .0E+00 .4E+01 5 11 .425E+00 .59E+00 .66E+00 .2E+00 G .0E+00 .2E+01 6 12 .393E+00 .77E-01 .12E+00 .1E+00 G .0E+00 .5E+00 7 13 .387E+00 .15E-01 .14E-01 .5E-01 S .0E+00 .1E+00 8 14 .387E+00 .34E-03 .30E-03 .7E-02 S .0E+00 .2E-01 9 15 .387E+00 .75E-05 .81E-05 .1E-02 G .0E+00 .3E-02 10 16 .387E+00 .13E-06 .42E-06 .3E-03 G .0E+00 .6E-03 11 17 .387E+00 .12E-06 .12E-06 .1E-03 S .0E+00 .3E-03 12 18 .387E+00 .33E-14 .37E-14 .2E-07 S .0E+00 .5E-07 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .386600E+00 RELDX .203E-07 FUNC. EVALS 18 GRAD. EVALS 26 PRELDF .368E-14 NPRELDF .368E-14 I FINAL X(I) D(I) G(I) 1 -.155437E+00 .138E+01 .351E-08 2 .694564E+00 .144E+01 .125E-07 //GO.SYSIN DD madsen.sgi cat >madsenb.sgi <<'//GO.SYSIN DD madsenb.sgi' DGLGB ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .579E+01 .84E+00 .10E+01 .2E+00 G .2E+01 .5E+01 3 5 .177E+01 .70E+00 .57E+00 .2E+00 S .0E+00 .3E+01 4 6 .660E+00 .63E+00 .59E+00 .4E+00 G .0E+00 .2E+01 5 7 .509E+00 .23E+00 .21E+00 .6E+00 G .0E+00 .7E+00 6 8 .500E+00 .17E-01 .17E-01 .9E+00 G .0E+00 .1E+00 7 9 .500E+00 .13E-04 .13E-04 .1E+01 S .0E+00 .4E-02 8 10 .500E+00 .50E-12 .50E-12 .1E+01 G .0E+00 .7E-06 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .500000E+00 RELDX .100E+01 FUNC. EVALS 10 GRAD. EVALS 9 PRELDF .496E-12 NPRELDF .496E-12 I FINAL X(I) D(I) G(I) 1 -.581806E-18 .100E+01 -.582E-18 2 .000000E+00 .188E+00 .000E+00 DGLGB NEEDED LIV .GE. ,I3,12H AND LV .GE. 92 DGLGB NEEDED LIV .GE. ,I3,12H AND LV .GE. 179 DGLFB ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .579E+01 .84E+00 .10E+01 .2E+00 G .2E+01 .5E+01 3 5 .177E+01 .70E+00 .57E+00 .2E+00 S .0E+00 .3E+01 4 6 .660E+00 .63E+00 .59E+00 .4E+00 G .0E+00 .2E+01 5 7 .509E+00 .23E+00 .21E+00 .6E+00 G .0E+00 .7E+00 6 8 .500E+00 .17E-01 .17E-01 .9E+00 G .0E+00 .1E+00 7 9 .500E+00 .13E-04 .13E-04 .1E+01 S .0E+00 .4E-02 8 11 .481E+00 .38E-01 .22E-08 .1E+01 G .3E-06 .6E-01 9 12 .402E+00 .16E+00 .12E+00 .5E+00 G .1E+01 .2E+00 10 13 .389E+00 .32E-01 .34E-01 .6E-01 G .0E+00 .1E+00 11 14 .389E+00 .17E-03 .19E-03 .7E-02 G .0E+00 .1E-01 12 15 .389E+00 .16E-05 .18E-05 .6E-03 G .0E+00 .1E-02 13 16 .389E+00 .13E-07 .13E-07 .5E-04 S .0E+00 .1E-03 14 17 .389E+00 -.29E-15 .14E-15 .5E-08 S .0E+00 .1E-07 ***** X- AND RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .388964E+00 RELDX .533E-08 FUNC. EVALS 17 GRAD. EVALS 28 PRELDF .137E-15 NPRELDF .137E-15 I FINAL X(I) D(I) G(I) 1 -.100000E+00 .140E+01 .852E-01 2 .670375E+00 .145E+01 .150E-07 DGLFB ON PROBLEM MADSEN AGAIN... NONDEFAULT VALUES.... LMAX0..... V(35) = .1000000E+00 I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 6 .521E+02 .38E+00 .41E+00 .4E-01 G .6E+01 .2E+01 2 7 .752E+01 .86E+00 .10E+01 .2E+00 G .4E+00 .6E+01 3 8 .131E+01 .83E+00 .83E+00 .3E+00 G .0E+00 .5E+01 4 9 .596E+00 .54E+00 .51E+00 .4E+00 G .0E+00 .2E+01 5 10 .503E+00 .16E+00 .14E+00 .7E+00 G .0E+00 .6E+00 6 11 .500E+00 .64E-02 .63E-02 .1E+01 G .0E+00 .9E-01 7 12 .500E+00 .69E-06 .69E-06 .1E+01 S .0E+00 .8E-03 8 14 .481E+00 .38E-01 .25E-08 .1E+01 G .2E-06 .7E-01 9 15 .402E+00 .16E+00 .12E+00 .5E+00 G .1E+01 .2E+00 10 16 .389E+00 .32E-01 .34E-01 .6E-01 G .0E+00 .1E+00 11 17 .389E+00 .17E-03 .19E-03 .7E-02 G .0E+00 .1E-01 12 18 .389E+00 .16E-05 .18E-05 .6E-03 G .0E+00 .1E-02 13 19 .389E+00 .13E-07 .13E-07 .5E-04 S .0E+00 .1E-03 14 20 .389E+00 .29E-15 .19E-16 .2E-08 S .0E+00 .4E-08 15 21 .389E+00 .00E+00 .19E-16 .1E-08 S .0E+00 .2E-08 ***** X- AND RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .388964E+00 RELDX .123E-08 FUNC. EVALS 21 GRAD. EVALS 30 PRELDF .194E-16 NPRELDF .194E-16 I FINAL X(I) D(I) G(I) 1 -.100000E+00 .140E+01 .852E-01 2 .670375E+00 .145E+01 .912E-08 //GO.SYSIN DD madsenb.sgi cat >mnpex1.sgi <<'//GO.SYSIN DD mnpex1.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 5 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .546E+02 1 2 .390E+02 .29E+00 .24E+00 .4E+00 G .2E+00 .9E+00 2 3 .341E+02 .13E+00 .13E+00 .5E+00 G .2E+01 .1E+01 3 4 .331E+02 .30E-01 .41E-01 .3E+00 G .0E+00 .5E+00 4 5 .324E+02 .20E-01 .18E-01 .2E+00 S .0E+00 .2E+00 5 6 .323E+02 .43E-02 .41E-02 .7E-01 S .0E+00 .1E+00 6 7 .323E+02 .20E-03 .22E-03 .1E-01 S .0E+00 .2E-01 7 8 .323E+02 .17E-04 .16E-04 .5E-02 S .0E+00 .8E-02 8 9 .323E+02 .33E-06 .31E-06 .5E-03 S .0E+00 .1E-02 9 10 .323E+02 .31E-08 .32E-08 .3E-04 S .0E+00 .5E-04 10 11 .323E+02 .12E-10 .13E-10 .4E-05 S .0E+00 .6E-05 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .322697E+02 RELDX .367E-05 FUNC. EVALS 11 GRAD. EVALS 11 PRELDF .132E-10 NPRELDF .132E-10 I FINAL X(I) D(I) G(I) 1 -.113148E+00 .100E+01 .727E-04 2 .127594E-01 .100E+01 .584E-05 3 .198357E+00 .100E+01 -.369E-05 4 .592164E+00 .100E+01 .640E-05 5 .312719E+00 .100E+01 .203E-04 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .48E-01 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .209E-02 ROW 2 .514E-02 .147 ROW 3 .645E-02 .113 .999E-01 ROW 4 -.241E-02 .549E-01 .385E-01 .463E-01 ROW 5 -.131E-01 -.101E-01 -.274E-01 .286E-01 .121 REGRESSION DIAGNOSTIC VECTOR NOT COMPUTED ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 TTIME -.113148E+00 -.247729E+01 .456742E-01 2 DBUS .127594E-01 .332417E-01 .383838E+00 3 DSTREETC .198357E+00 .627560E+00 .316076E+00 4 B21 .592164E+00 .275152E+01 .215214E+00 5 B22 .312719E+00 .898071E+00 .348211E+00 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.322697E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .453219E+02 1 - L(EST)/L(0): = .412538E+00 1 - (L(EST)-NPAR)/L(0) = .321514E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .302235E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.113148E+00 -.100000E+03 .100000E+03 DBUS .127594E-01 -.100000E+03 .100000E+03 DSTREETC .198357E+00 -.100000E+03 .100000E+03 B21 .592164E+00 -.100000E+03 .100000E+03 B22 .312719E+00 -.100000E+03 .100000E+03 //GO.SYSIN DD mnpex1.sgi cat >mnpex1b.sgi <<'//GO.SYSIN DD mnpex1b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 5 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .546E+02 1 2 .390E+02 .29E+00 .24E+00 .4E+00 G .2E+00 .9E+00 2 3 .341E+02 .13E+00 .13E+00 .5E+00 G .2E+01 .1E+01 3 4 .331E+02 .30E-01 .41E-01 .3E+00 G .0E+00 .5E+00 4 5 .324E+02 .20E-01 .18E-01 .2E+00 S .0E+00 .2E+00 5 6 .323E+02 .43E-02 .41E-02 .7E-01 S .0E+00 .1E+00 6 7 .323E+02 .20E-03 .22E-03 .1E-01 S .0E+00 .2E-01 7 8 .323E+02 .17E-04 .16E-04 .5E-02 S .0E+00 .8E-02 8 9 .323E+02 .33E-06 .31E-06 .5E-03 S .0E+00 .1E-02 9 10 .323E+02 .31E-08 .32E-08 .3E-04 S .0E+00 .5E-04 10 11 .323E+02 .12E-10 .13E-10 .4E-05 S .0E+00 .6E-05 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .322697E+02 RELDX .368E-05 FUNC. EVALS 11 GRAD. EVALS 11 PRELDF .133E-10 NPRELDF .133E-10 I FINAL X(I) D(I) G(I) 1 -.113148E+00 .100E+01 .730E-04 2 .127594E-01 .100E+01 .554E-05 3 .198357E+00 .100E+01 -.378E-05 4 .592164E+00 .100E+01 .659E-05 5 .312719E+00 .100E+01 .204E-04 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.322697E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .453219E+02 1 - L(EST)/L(0): = .412538E+00 1 - (L(EST)-NPAR)/L(0) = .321514E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .302235E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.113148E+00 -.100000E+03 .100000E+03 DBUS .127594E-01 -.100000E+03 .100000E+03 DSTREETC .198357E+00 -.100000E+03 .100000E+03 B21 .592164E+00 -.100000E+03 .100000E+03 B22 .312719E+00 -.100000E+03 .100000E+03 //GO.SYSIN DD mnpex1b.sgi cat >mnpex2.sgi <<'//GO.SYSIN DD mnpex2.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS UNCORRELATED RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 6 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 6 SigT .100000E+01 .100000E-03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 6 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .535E+02 1 2 .346E+02 .35E+00 .30E+00 .4E+00 G .6E+01 .1E+01 2 4 .327E+02 .55E-01 .51E-01 .9E-01 G .8E+01 .4E+00 3 5 .324E+02 .67E-02 .19E-01 .2E+00 G .2E+00 .8E+00 4 7 .322E+02 .91E-02 .11E-01 .8E-01 G-S .0E+00 .3E+00 5 9 .321E+02 .92E-03 .14E-02 .6E-01 S .8E+00 .2E+00 6 10 .321E+02 .84E-03 .57E-03 .6E-01 S .6E-01 .2E+00 7 11 .321E+02 .39E-03 .17E-02 .2E+00 G .5E-01 .6E+00 8 12 .320E+02 .12E-02 .29E-02 .2E+00 S .0E+00 .4E+00 9 13 .320E+02 .15E-02 .13E-02 .6E-01 S .0E+00 .1E+00 10 14 .320E+02 .17E-03 .12E-03 .4E-01 S .0E+00 .6E-01 11 15 .320E+02 .46E-04 .40E-04 .3E-01 S .0E+00 .5E-01 12 16 .320E+02 .25E-05 .24E-05 .2E-02 S .0E+00 .3E-02 13 17 .320E+02 .14E-06 .14E-06 .4E-03 S .0E+00 .6E-03 14 18 .320E+02 .31E-08 .36E-08 .2E-03 S .0E+00 .3E-03 15 20 .320E+02 .16E-09 .17E-09 .4E-04 G-S .0E+00 .7E-04 16 21 .320E+02 .22E-11 .22E-11 .4E-05 S .0E+00 .8E-05 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .319875E+02 RELDX .412E-05 FUNC. EVALS 21 GRAD. EVALS 17 PRELDF .224E-11 NPRELDF .224E-11 I FINAL X(I) D(I) G(I) 1 -.235784E+00 .100E+01 -.156E-04 2 -.228115E+00 .100E+01 .769E-06 3 -.646605E-03 .100E+01 -.240E-05 4 .365699E+00 .100E+01 .563E-06 5 .614115E+00 .100E+01 -.132E-05 6 .122138E+00 .100E+01 -.173E-04 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .26E-01 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .355E-01 ROW 2 .534E-01 .381 ROW 3 .512E-01 .293 .266 ROW 4 .851E-01 .409 .344 .596 ROW 5 -.937E-01 -.693E-01 -.937E-01 -.164 .379 ROW 6 -.244E-01 -.337E-01 -.315E-01 -.576E-01 .631E-01 .181E-01 REGRESSION DIAGNOSTIC VECTOR NOT COMPUTED ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 TTIME -.235784E+00 -.125086E+01 .188498E+00 2 DBUS -.228115E+00 -.369418E+00 .617500E+00 3 DSTREETC -.646605E-03 -.125277E-02 .516139E+00 4 B21 .365699E+00 .473542E+00 .772263E+00 5 B22 .614115E+00 .997767E+00 .615489E+00 6 SigT .122138E+00 .907365E+00 .134607E+00 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.319875E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .458863E+02 1 - L(EST)/L(0): = .417675E+00 1 - (L(EST)-NPAR)/L(0) = .308446E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .307878E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.235784E+00 -.100000E+03 .100000E+03 DBUS -.228115E+00 -.100000E+03 .100000E+03 DSTREETC -.646605E-03 -.100000E+03 .100000E+03 B21 .365699E+00 -.100000E+03 .100000E+03 B22 .614115E+00 -.100000E+03 .100000E+03 SigT .122138E+00 .100000E-03 .100000E+03 //GO.SYSIN DD mnpex2.sgi cat >mnpex2b.sgi <<'//GO.SYSIN DD mnpex2b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS UNCORRELATED RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 6 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 6 SigT .100000E+01 .100000E-03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 6 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .535E+02 1 2 .346E+02 .35E+00 .30E+00 .4E+00 G .6E+01 .1E+01 2 4 .327E+02 .55E-01 .51E-01 .9E-01 G .8E+01 .4E+00 3 5 .324E+02 .67E-02 .19E-01 .2E+00 G .2E+00 .8E+00 4 7 .323E+02 .59E-02 .19E-01 .1E+00 G .7E+00 .4E+00 5 8 .321E+02 .57E-02 .50E-02 .4E-01 S .0E+00 .2E+00 6 9 .321E+02 .65E-03 .49E-03 .7E-01 S .0E+00 .2E+00 7 11 .320E+02 .69E-03 .83E-03 .6E-01 G .6E+00 .2E+00 8 12 .320E+02 .65E-03 .57E-03 .9E-01 G .0E+00 .2E+00 9 13 .320E+02 .10E-03 .82E-03 .9E-01 G .5E+00 .2E+00 10 14 .320E+02 .55E-03 .46E-03 .6E-01 S .0E+00 .9E-01 11 15 .320E+02 .83E-05 .90E-05 .1E-01 G .0E+00 .2E-01 12 17 .320E+02 .31E-05 .60E-05 .5E-02 G .1E+01 .7E-02 13 18 .320E+02 .16E-05 .14E-05 .4E-02 S .0E+00 .6E-02 14 19 .320E+02 .72E-07 .93E-07 .9E-03 S .0E+00 .2E-02 15 21 .320E+02 .15E-07 .26E-07 .3E-03 G .1E+01 .6E-03 16 22 .320E+02 .15E-08 .14E-08 .9E-04 S .0E+00 .2E-03 17 23 .320E+02 .42E-10 .47E-10 .2E-04 S .0E+00 .2E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .319875E+02 RELDX .158E-04 FUNC. EVALS 23 GRAD. EVALS 18 PRELDF .466E-10 NPRELDF .466E-10 I FINAL X(I) D(I) G(I) 1 -.235786E+00 .100E+01 .176E-03 2 -.228117E+00 .100E+01 .329E-05 3 -.649168E-03 .100E+01 -.362E-04 4 .365697E+00 .100E+01 .884E-05 5 .614124E+00 .100E+01 .534E-04 6 .122139E+00 .100E+01 .476E-04 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.319875E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .458863E+02 1 - L(EST)/L(0): = .417675E+00 1 - (L(EST)-NPAR)/L(0) = .308446E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .307878E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.235786E+00 -.100000E+03 .100000E+03 DBUS -.228117E+00 -.100000E+03 .100000E+03 DSTREETC -.649168E-03 -.100000E+03 .100000E+03 B21 .365697E+00 -.100000E+03 .100000E+03 B22 .614124E+00 -.100000E+03 .100000E+03 SigT .122139E+00 .100000E-03 .100000E+03 //GO.SYSIN DD mnpex2b.sgi cat >pmain.sgi <<'//GO.SYSIN DD pmain.sgi' * 28 **** problem e1 **** * 10 Example Frome '84 pp. 8-10 (Table 2, In-Vitro Dose Response, 192 Ir ra * 7 Run 1: calling DGLG with PS = 2 I INITIAL X(I) D(I) 1 .499434E-01 .963E+02 2 .578438E-01 .259E+03 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .486E+03 1 2 .486E+03 .49E-03 .49E-03 .2E-01 G .2E+00 .9E+00 2 3 .486E+03 .13E-03 .14E-03 .2E-01 G .0E+00 .9E+00 3 4 .486E+03 .25E-06 .25E-06 .8E-03 G .0E+00 .3E-01 4 5 .486E+03 .14E-11 .14E-11 .2E-05 G .0E+00 .8E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .486108E+03 RELDX .201E-05 FUNC. EVALS 5 GRAD. EVALS 5 PRELDF .145E-11 NPRELDF .145E-11 I FINAL X(I) D(I) G(I) 1 .359307E-01 .102E+03 -.165E-07 2 .621812E-01 .259E+03 -.131E-07 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .20 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .304E-03 ROW 2 -.990E-04 .472E-04 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .678E-01 .122E-01 .678E-01 .312E-02 .122E-01 .580E-01 .312E-02 .839E-04 .117E-01 .839E-04 .746E-02 .100 .183E-05 .203E-02 .843E-02 .147 .109E-01 .210E-01 .215E-02 .967E-01 DEVIANCE = 12.6690951 * 28 **** problem e2.2 **** * 10 Data for model (2.2) in Frome '84. * 7 Run 2: calling DGLG with PS = 3 I INITIAL X(I) D(I) 1 .353130E+01 .520E+01 2 .359229E+01 .122E+02 3 .227780E+01 .724E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.865E+04 1 3 -.865E+04 .17E-03 .17E-03 .2E-01 G .5E+00 .1E+01 2 4 -.865E+04 .11E-03 .11E-03 .3E-01 G .0E+00 .3E+01 3 5 -.865E+04 .11E-06 .11E-06 .6E-03 G .0E+00 .5E-01 4 6 -.865E+04 .19E-12 .19E-12 .8E-06 G .0E+00 .9E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.865021E+04 RELDX .832E-06 FUNC. EVALS 6 GRAD. EVALS 5 PRELDF .188E-12 NPRELDF .188E-12 I FINAL X(I) D(I) G(I) 1 .285932E+01 .544E+01 -.500E-09 2 .379915E+01 .121E+02 -.624E-09 3 .225735E+01 .713E+01 .240E-09 4 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 4 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .25 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .944E-01 ROW 2 -.344E-01 .200E-01 ROW 3 -.271E-02 .455E-02 .215E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .304E-01 .122E-02 .195 .178E-01 .831E-01 .482E-01 .131 .394E-01 .477E-01 .202E-01 .434E-01 .173E-01 .294E-02 .358E-01 .506E-01 .268E-01 .108E-02 .348E-01 1.39 .835E-01 .577E-02 .185 .411E-02 .108E-01 .236E-01 .224 .369E-04 DEVIANCE = 29.9589608 * 28 **** problem e2.6 **** * 10 Data for model (2.6) in Frome '84. * 7 Run 3: calling DGLG with PS = 3 I INITIAL X(I) D(I) 1 .800000E+01 .713E+01 2 .100000E+01 .220E+02 3 .310000E+01 .362E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.796E+04 1 4 -.820E+04 .30E-01 .30E-01 .2E-01 G .1E+02 .4E+01 2 5 -.860E+04 .47E-01 .57E-01 .1E+00 G .1E+01 .1E+02 3 6 -.863E+04 .27E-02 .40E-02 .1E+00 S .0E+00 .2E+02 4 7 -.865E+04 .27E-02 .34E-02 .6E-01 S .0E+00 .1E+02 5 8 -.865E+04 .23E-03 .18E-03 .2E-01 S .0E+00 .2E+01 6 9 -.865E+04 .19E-04 .17E-04 .6E-02 G .0E+00 .1E+01 7 10 -.865E+04 .59E-06 .58E-06 .1E-02 S .0E+00 .1E+00 8 11 -.865E+04 .15E-08 .14E-08 .5E-04 S .0E+00 .7E-02 9 12 -.865E+04 .31E-11 .31E-11 .2E-05 S .0E+00 .3E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.865104E+04 RELDX .222E-05 FUNC. EVALS 12 GRAD. EVALS 10 PRELDF .313E-11 NPRELDF .313E-11 I FINAL X(I) D(I) G(I) 1 .542752E+01 .105E+02 -.756E-05 2 .271635E+00 .295E+02 -.265E-04 3 .740517E+01 .155E+01 .150E-05 4 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 4 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .37E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .436E-01 ROW 2 -.114E-01 .469E-02 ROW 3 -.737E-01 -.450E-03 .805 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .485E-03 .145 .945E-02 .175E-01 .452E-01 .833E-03 .124E-01 .268E-02 .283E-01 .105 .219E-02 .755E-02 .578E-02 .174E-01 .455E-01 .352E-01 .669E-03 .868E-01 1.59 .372 .124 .395 .554E-03 .101E-02 .272E-01 .138 .426E-01 DEVIANCE = 28.2983767 * 28 **** problem e2.8 **** * 10 Data for model (2.8) in Frome '84. * 7 Run 4: calling DGLG with PS = 4 I INITIAL X(I) D(I) 1 .300000E+01 .517E+01 2 .200000E+01 .290E+02 3 .100000E+01 .916E+02 4 .300000E+01 .107E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .113E+09 1 3 .105E+09 .72E-01 .74E-01 .6E-02 G .3E+07 .2E+01 2 5 .361E+08 .66E+00 .11E+01 .9E-01 G .2E+06 .2E+02 3 6 .307E+08 .15E+00 .56E+00 .1E+00 S .3E+00 .7E+04 4 8 .178E+08 .42E+00 .32E+00 .4E-01 S .6E+00 .2E+04 5 9 .104E+08 .42E+00 .37E+00 .8E-01 S .4E+00 .3E+04 6 10 .477E+07 .54E+00 .57E+00 .1E+00 S .4E+00 .3E+04 7 11 .262E+07 .45E+00 .31E+00 .3E+00 S .2E-01 .3E+04 8 12 .125E+07 .52E+00 .39E+00 .4E+00 S .6E-02 .3E+04 9 13 .600E+06 .52E+00 .42E+00 .6E+00 S .1E-01 .3E+04 10 14 .295E+06 .51E+00 .37E+00 .4E+00 S .0E+00 .1E+04 11 15 .142E+06 .52E+00 .39E+00 .4E+00 S .0E+00 .2E+04 12 16 .729E+05 .49E+00 .34E+00 .7E-01 S .0E+00 .4E+03 13 17 .390E+05 .47E+00 .32E+00 .1E+00 S .0E+00 .4E+03 14 18 .223E+05 .43E+00 .30E+00 .8E-01 S .0E+00 .2E+03 15 19 .144E+05 .36E+00 .25E+00 .7E-01 S .0E+00 .2E+03 16 20 .108E+05 .25E+00 .18E+00 .6E-01 S .0E+00 .1E+03 17 21 .930E+04 .14E+00 .10E+00 .5E-01 S .0E+00 .8E+02 18 22 .882E+04 .51E-01 .40E-01 .4E-01 S .0E+00 .5E+02 19 23 .872E+04 .12E-01 .99E-02 .4E-01 S .0E+00 .4E+02 20 24 .870E+04 .23E-02 .19E-02 .3E-01 S .0E+00 .3E+02 21 25 .870E+04 .20E-03 .20E-03 .1E-01 G .0E+00 .1E+02 22 26 .870E+04 .13E-04 .15E-04 .4E-02 G .0E+00 .3E+01 23 27 .870E+04 .12E-05 .12E-05 .8E-03 S .0E+00 .6E+00 24 28 .870E+04 .12E-08 .11E-08 .2E-04 S .0E+00 .2E-01 25 29 .870E+04 .13E-11 .14E-11 .5E-06 G .0E+00 .4E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .869542E+04 RELDX .540E-06 FUNC. EVALS 29 GRAD. EVALS 26 PRELDF .135E-11 NPRELDF .135E-11 I FINAL X(I) D(I) G(I) 1 .337698E+01 .557E+01 .601E-04 2 -.889796E+01 .301E+02 .131E-04 3 .829339E+00 .940E+02 -.623E-04 4 -.870603E+01 .997E+01 -.131E-04 5 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 5 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .45E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .322E-01 ROW 2 -.452E-02 .509E-01 ROW 3 .972E-03 -.158E-01 .503E-02 ROW 4 -.260E-02 -.778E-02 .213E-02 .125E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .362E-02 .794E-04 .274E-02 .294 .192 .128E-01 .545E-02 .722E-04 .274E-02 .101 .235E-03 .291E-06 .211 .543E-01 .195 .188E-01 3.72 .229 .246E-03 .185 .146E-05 .779 .825 .148E-01 .208E-02 .201E-02 .283E-02 .210E-01 .213E-01 .805E-03 DEVIANCE = 43.5094306 * 28 **** problem e3.1 **** * 10 Data for model (3.1) in Frome '84. * 7 Run 5: calling DGLG with PS = 2 I INITIAL X(I) D(I) 1 .317714E-01 .157E+03 2 .467588E-02 .550E+04 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .109E+04 1 2 .109E+04 .25E-03 .27E-03 .1E-01 G .1E+00 .9E+00 2 3 .109E+04 .18E-05 .18E-05 .1E-02 G .0E+00 .8E-01 3 4 .109E+04 .20E-10 .20E-10 .4E-05 G .0E+00 .2E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .108871E+04 RELDX .448E-05 FUNC. EVALS 4 GRAD. EVALS 4 PRELDF .196E-10 NPRELDF .196E-10 I FINAL X(I) D(I) G(I) 1 .266983E-01 .175E+03 -.143E-05 2 .477899E-02 .549E+04 -.527E-06 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .28E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .435E-04 ROW 2 -.697E-06 .443E-07 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). 9.78 .179 .326E-02 .677 .325 DEVIANCE = 6.03781877 * 28 **** problem e3.3 **** * 10 Data for model (3.3) in Frome '84. * 7 Run 6: calling DGLG with PS = 2 I INITIAL X(I) D(I) 1 .317714E-01 .251E+02 2 .467588E-02 .137E+04 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .171E+04 1 3 .162E+04 .53E-01 .53E-01 .2E+00 G .9E+01 .3E+01 2 5 .128E+04 .21E+00 .20E+00 .8E+00 G .5E+00 .2E+02 3 6 .113E+04 .12E+00 .13E+00 .4E+00 S .9E-01 .3E+02 4 7 .110E+04 .19E-01 .17E-01 .1E+00 S .0E+00 .2E+02 5 8 .110E+04 .10E-02 .95E-03 .3E-01 S .0E+00 .4E+01 6 9 .110E+04 .14E-04 .14E-04 .4E-02 S .0E+00 .6E+00 7 10 .110E+04 .77E-08 .77E-08 .9E-04 S .0E+00 .1E-01 8 11 .110E+04 .45E-13 .44E-13 .2E-06 S .0E+00 .3E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .110260E+04 RELDX .226E-06 FUNC. EVALS 11 GRAD. EVALS 9 PRELDF .444E-13 NPRELDF .444E-13 I FINAL X(I) D(I) G(I) 1 -.276204E+01 .191E+02 .293E-06 2 .307811E-01 .123E+04 .212E-04 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .64E-02 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .162E-01 ROW 2 -.229E-03 .389E-05 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). 6.10 8.05 .801 .943 .405 DEVIANCE = 33.8225541 * 28 **** problem e3.5 **** * 10 Model (3.5), p. 25 of Frome '84 * 7 Run 7: calling DGLG with PS = 9 I INITIAL X(I) D(I) 1 .249281E+00 .615E+02 2 -.809728E-01 .391E+02 3 -.683860E-01 .570E+02 4 -.619460E-01 .464E+02 5 -.507099E-01 .382E+02 6 -.167601E-01 .429E+02 7 .218039E-02 .358E+02 8 .302952E-01 .287E+02 9 .629407E-01 .288E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .150E+05 1 4 .143E+05 .49E-01 .49E-01 .1E+00 G .3E+02 .5E+01 2 6 .778E+04 .45E+00 .44E+00 .7E+00 G .9E+00 .6E+02 3 7 .495E+04 .36E+00 .32E+00 .5E+00 G .3E-01 .1E+03 4 8 .433E+04 .12E+00 .10E+00 .3E+00 G .0E+00 .8E+02 5 9 .422E+04 .26E-01 .23E-01 .2E+00 G .0E+00 .5E+02 6 10 .422E+04 .14E-02 .13E-02 .4E-01 G .0E+00 .1E+02 7 11 .422E+04 .49E-05 .49E-05 .2E-02 G .0E+00 .7E+00 8 12 .422E+04 .89E-10 .89E-10 .7E-05 G .0E+00 .3E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .421723E+04 RELDX .684E-05 FUNC. EVALS 12 GRAD. EVALS 9 PRELDF .893E-10 NPRELDF .893E-10 I FINAL X(I) D(I) G(I) 1 .258357E+01 .447E+02 .219E-06 2 -.361245E+01 .146E+02 .295E-06 3 -.316190E+01 .338E+02 .390E-07 4 -.307284E+01 .277E+02 .242E-07 5 -.297116E+01 .233E+02 .173E-07 6 -.280542E+01 .237E+02 .405E-07 7 -.265190E+01 .226E+02 .247E-07 8 -.241710E+01 .183E+02 .189E-07 9 -.220367E+01 .197E+02 .201E-07 10 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 10 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .14 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .491E-02 ROW 2 -.343E-02 .711E-02 ROW 3 -.344E-02 .240E-02 .329E-02 ROW 4 -.326E-02 .228E-02 .229E-02 .347E-02 ROW 5 -.314E-02 .219E-02 .220E-02 .209E-02 .386E-02 ROW 6 -.289E-02 .202E-02 .203E-02 .192E-02 .185E-02 .348E-02 ROW 7 -.293E-02 .205E-02 .206E-02 .195E-02 .188E-02 .173E-02 .371E-02 ROW 8 -.261E-02 .182E-02 .183E-02 .173E-02 .167E-02 .153E-02 .156E-02 .437E-02 ROW 9 -.246E-02 .172E-02 .172E-02 .163E-02 .157E-02 .145E-02 .147E-02 .130E-02 .380E-02 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .172E-06 .329E-04 .320E-01 .621E-03 .982E-02 .665E-02 .285 2.97 .177E-01 .485E-01 .181E-01 .866E-02 .348E-02 .148E-01 .538E-01 .425E-02 2.30 .116 .473E-01 .770E-01 .102E-03 .560E-02 .144E-01 .175E-01 .105 .992 .232 .133E-05 .198E-01 .478E-01 .284E-03 .833E-02 .370E-03 .133E-04 1.31 .112 .180E-03 .296E-01 .101E-01 .130E-02 .113E-02 .146E-01 .132 .308E-02 .110E-01 .159E-03 .638E-02 .241E-01 .994E-02 .193E-01 .378E-01 .105 .238 .199E-02 .287E-01 .619E-01 .382E-01 .320E-01 .658E-01 .488E-01 .631E-02 .149 .104 .163E-01 .124E-03 .116 .136 .607E-02 .279 .335E-01 6.06 .165E-01 DEVIANCE = 133.614611 * 28 **** problem ex1 **** * 10 PRLRT1.DAT: RC3- BIOMETRICS ( 1965 ) P. 613 * 7 Run 8: calling DGLG with PS = 2 I INITIAL X(I) D(I) 1 .157316E+03 .347E+00 2 -.813265E+02 .144E+00 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.524E+04 1 3 -.524E+04 .29E-04 .29E-04 .1E-01 G .1E-01 .2E+01 2 4 -.524E+04 .12E-05 .12E-05 .3E-02 G .0E+00 .5E+00 3 5 -.524E+04 .87E-11 .87E-11 .6E-05 G .0E+00 .8E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.523742E+04 RELDX .587E-05 FUNC. EVALS 5 GRAD. EVALS 4 PRELDF .874E-11 NPRELDF .874E-11 I FINAL X(I) D(I) G(I) 1 .162108E+03 .346E+00 -.670E-09 2 -.920828E+02 .144E+00 -.186E-09 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .12 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 72.8 ROW 2 -164. 418. REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .730E-01 .252 .160E-02 .231 .467E-01 .151 .352 .109E-01 .383E-01 .226E-01 .560 DEVIANCE = 14.1970648 * 28 **** problem ex2 **** * 10 PRLLT3.DAT: NELDER-WEDDERBURN (1972) P.378 * 7 Run 9: calling DGLG with PS = 9 I INITIAL X(I) D(I) 1 .503000E+00 .149E+02 2 .133298E+01 .700E+01 3 .169254E+01 .707E+01 4 .228643E+01 .768E+01 5 .203102E+01 .663E+01 6 -.184726E-01 .640E+01 7 .480529E-01 .648E+01 8 .864793E+00 .100E+02 9 -.173518E+00 .436E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.354E+03 1 2 -.355E+03 .28E-02 .27E-02 .2E-01 G .7E+00 .9E+00 2 3 -.355E+03 .11E-02 .11E-02 .4E-01 G .2E-01 .2E+01 3 4 -.355E+03 .15E-03 .14E-03 .4E-01 G .0E+00 .2E+01 4 5 -.355E+03 .39E-05 .38E-05 .4E-02 G .0E+00 .2E+00 5 6 -.355E+03 .13E-06 .14E-06 .1E-02 S .0E+00 .6E-01 6 7 -.355E+03 .56E-09 .65E-09 .2E-04 S .0E+00 .1E-02 7 8 -.355E+03 .14E-10 .14E-10 .8E-05 S .0E+00 .5E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.355016E+03 RELDX .767E-05 FUNC. EVALS 8 GRAD. EVALS 8 PRELDF .140E-10 NPRELDF .140E-10 I FINAL X(I) D(I) G(I) 1 .356637E+00 .149E+02 -.135E-06 2 .137420E+01 .725E+01 -.369E-05 3 .186195E+01 .707E+01 .900E-06 4 .243910E+01 .779E+01 .150E-04 5 .250887E+01 .663E+01 .238E-05 6 .626834E-01 .646E+01 .579E-05 7 .603038E-01 .666E+01 -.306E-05 8 .837804E+00 .101E+02 -.104E-04 9 -.205107E+00 .443E+02 .172E-03 10 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 10 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .28E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .141 ROW 2 -.884E-01 .910E-01 ROW 3 -.121 .893E-01 .143 ROW 4 -.147 .104 .150 .203 ROW 5 -.168 .115 .170 .214 .270 ROW 6 -.308E-01 .254E-02 .480E-02 .682E-02 .865E-02 .506E-01 ROW 7 -.288E-01 .132E-02 .236E-02 .333E-02 .437E-02 .264E-01 .508E-01 ROW 8 -.190E-01 -.377E-02 -.726E-02 -.102E-01 -.126E-01 .258E-01 .267E-01 .377E-01 ROW 9 .141E-01 -.753E-02 -.136E-01 -.184E-01 -.221E-01 -.145E-02 -.140E-02 .127E-03 .250E-02 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .230E-01 .261 .220E-01 1.63 .333E-02 .988E-03 4.61 1.64 .198 .930E-01 .277E-01 .267 1.06 .486 .258 .649 .194E-01 .108 .359 69.3 DEVIANCE = 14.0764184 * 28 **** problem ex3 **** * 10 PRNLT1.DAT: TILL AND MCCUL. (1961) DATA-- TARGET MODEL * 7 Run 10: calling DGLG with PS = 3 I INITIAL X(I) D(I) 1 .800000E+01 .264E+01 2 .100000E+01 .764E+02 3 .310000E+01 .550E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.584E+03 1 3 -.590E+03 .90E-02 .93E-02 .1E-01 G .5E+00 .2E+01 2 4 -.591E+03 .16E-02 .16E-02 .2E-01 G .0E+00 .4E+01 3 5 -.591E+03 .99E-05 .99E-05 .3E-03 G .0E+00 .7E-01 4 6 -.591E+03 .95E-09 .88E-09 .3E-04 G .0E+00 .6E-02 5 7 -.591E+03 .68E-11 .63E-11 .3E-05 G .0E+00 .5E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.590639E+03 RELDX .256E-05 FUNC. EVALS 7 GRAD. EVALS 6 PRELDF .630E-11 NPRELDF .630E-11 I FINAL X(I) D(I) G(I) 1 .763642E+01 .291E+01 -.146E-07 2 .934106E+00 .852E+02 .338E-04 3 .289235E+01 .635E+01 -.115E-04 4 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 4 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .10E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .869 ROW 2 -.146E-01 .169E-02 ROW 3 -.552 .277E-01 .611 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). 2.58 .306 .385 .788 .396E-01 1.78 .569 DEVIANCE = 8.01739137 * 28 **** problem ex8-10 **** * 10 Example Frome '84 pp. 8-10 (Table 2, In-Vitro Dose Response, 192 Ir r * 7 Run 11: calling DGLG with PS = 2 I INITIAL X(I) D(I) 1 .499434E-01 .963E+02 2 .578438E-01 .259E+03 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .486E+03 1 2 .486E+03 .49E-03 .49E-03 .2E-01 G .2E+00 .9E+00 2 3 .486E+03 .13E-03 .14E-03 .2E-01 G .0E+00 .9E+00 3 4 .486E+03 .25E-06 .25E-06 .8E-03 G .0E+00 .3E-01 4 5 .486E+03 .14E-11 .14E-11 .2E-05 G .0E+00 .8E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .486108E+03 RELDX .201E-05 FUNC. EVALS 5 GRAD. EVALS 5 PRELDF .145E-11 NPRELDF .145E-11 I FINAL X(I) D(I) G(I) 1 .359307E-01 .102E+03 -.165E-07 2 .621812E-01 .259E+03 -.131E-07 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .20 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .304E-03 ROW 2 -.990E-04 .472E-04 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .564 .313 .245E-01 4.06 DEVIANCE = 1.38059456 * 28 **** problem mn202 **** * 10 Example on p. 202 of McCullagh and Nelder * 7 Run 12: calling DGLG with PS = 7 I INITIAL X(I) D(I) 1 .100000E+01 .729E+01 2 .100000E+01 .952E-01 3 .400000E+02 .226E-02 4 .200000E+01 .191E+00 5 .220000E+02 .151E-01 6 .300000E+01 .125E+00 7 .320000E+02 .104E-01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .310E+03 1 2 .272E+03 .12E+00 .17E+00 .4E-01 G .6E+02 .9E+00 2 4 .230E+03 .15E+00 .14E+00 .3E-01 G .8E+01 .9E+00 3 8 .188E+03 .18E+00 .20E+00 .1E+00 G .4E+01 .3E+01 4 10 .180E+03 .47E-01 .66E-01 .6E-01 G .1E+00 .9E+01 5 13 .177E+03 .11E-01 .14E-01 .2E-01 G .2E-01 .1E+02 6 14 .176E+03 .10E-01 .13E-01 .2E-01 G .2E-01 .1E+02 7 15 .172E+03 .19E-01 .19E+01 .2E-01 S .5E+01 .1E+02 8 18 .166E+03 .37E-01 .54E-01 .1E+00 S .7E-02 .3E+02 9 19 .159E+03 .45E-01 .33E-01 .3E+00 S .2E-02 .3E+02 10 20 .158E+03 .35E-02 .25E-01 .2E+00 S -.1E-01 .2E+02 11 24 .157E+03 .75E-02 .79E-02 .1E+00 G-S-G .3E-02 .9E+01 12 25 .157E+03 .14E-02 .25E-02 .2E+00 G .6E-04 .9E+01 13 28 .156E+03 .14E-02 .15E-02 .8E-01 G .3E-02 .1E+01 14 29 .156E+03 .87E-04 .88E-04 .1E+00 G .2E-02 .1E+01 15 31 .156E+03 .19E-04 .18E-04 .1E-01 G .2E-01 .2E+00 16 34 .156E+03 .73E-05 .69E-05 .3E-01 G .0E+00 .3E+00 17 36 .156E+03 .51E-05 .48E-05 .2E-01 G .1E-01 .2E+00 18 37 .156E+03 .32E-05 .51E-05 .5E-01 G .7E-03 .5E+00 19 38 .156E+03 .28E-05 .28E-05 .6E-02 G .0E+00 .8E-01 20 39 .156E+03 .25E-08 .22E-08 .1E-02 G .0E+00 .1E-01 21 40 .156E+03 .41E-10 .36E-10 .1E-03 G .0E+00 .1E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .156435E+03 RELDX .135E-03 FUNC. EVALS 40 GRAD. EVALS 22 PRELDF .359E-10 NPRELDF .359E-10 I FINAL X(I) D(I) G(I) 1 .974631E-01 .384E+02 -.552E-05 2 .131572E+02 .263E+00 -.281E-07 3 .446198E+02 .626E-01 .352E-08 4 .692185E+00 .126E+01 -.209E-06 5 .154166E+02 .498E-01 .115E-06 6 .135614E+01 .613E+00 -.727E-07 7 .327904E+02 .220E-01 .280E-08 8 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 8 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .86E-04 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .289E-01 ROW 2 -1.60 515. ROW 3 -4.65 .155E+04 .495E+04 ROW 4 -.874 -.567 -1.14 69.3 ROW 5 -15.6 -3.05 -8.09 .127E+04 .239E+05 ROW 6 -1.80 -1.08 -2.15 -.618E-01 -.383 287. ROW 7 -34.2 -5.46 -14.5 -.371 -3.43 .563E+04 .114E+06 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .118E-03 .267E-03 .360E-04 .241E-04 .291E-03 .466E-03 .932E-08 .437E-05 .149E-03 .259E-03 .365E-04 .780E-04 .339E-03 .709E-03 .336E-03 .113E-04 .405E-04 .734E-04 .286E-03 .467E-04 .194E-04 .809E-04 .129E-03 .351E-05 .200E-03 .268E-03 .419E-04 .132E-03 .104E-04 .917E-04 .238E-04 .407E-03 .122E-04 .570E-03 .243E-03 .202E-02 .611E-03 .307E-04 .513E-04 .123E-06 .197E-03 .460E-04 .321E-05 .341E-05 .275E-03 .373E-04 .992E-04 .113E-03 .745E-03 .374E-03 .985E-05 .216E-05 .398E-04 .630E-04 .603E-03 .389E-04 .307E-03 .113E-04 .444E-04 .317E-03 .328E-03 .236E-05 .492E-04 .143E-03 DEVIANCE = 1.96943890E-01 * 28 **** problem mn202.1 **** * 10 Example on p. 202 of McCullagh and Nelder * 7 Run 13: calling DGLG with PS = 7 I INITIAL X(I) D(I) 1 .100000E+01 .535E+01 2 .200000E+01 .641E+00 3 .300000E+01 .427E+00 4 .400000E+01 .394E+00 5 .500000E+01 .300E+00 6 .600000E+01 .268E+00 7 .700000E+01 .223E+00 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .429E+03 1 3 .217E+03 .50E+00 .70E+00 .2E+00 G .2E+02 .4E+01 2 6 .181E+03 .16E+00 .17E+00 .1E+00 G .1E+02 .2E+01 3 7 .168E+03 .75E-01 .17E+00 .5E+00 G .4E+00 .7E+01 4 9 .163E+03 .25E-01 .23E-01 .1E+00 G .5E-03 .1E+02 5 10 .158E+03 .31E-01 .15E-01 .2E+00 G .5E-03 .1E+02 6 13 .157E+03 .93E-02 .83E-02 .2E+00 G .3E-02 .4E+01 7 15 .157E+03 .17E-02 .16E-02 .3E-01 G .4E+00 .5E+00 8 16 .156E+03 .52E-03 .51E-03 .4E-01 G .2E-01 .9E+00 9 17 .156E+03 .64E-04 .67E-04 .6E-01 G .9E-02 .8E+00 10 19 .156E+03 .38E-04 .42E-04 .6E-01 G .4E-02 .1E+01 11 20 .156E+03 .26E-04 .49E-04 .1E+00 G .1E-02 .2E+01 12 21 .156E+03 .20E-04 .34E-04 .9E-01 G .0E+00 .1E+01 13 22 .156E+03 .15E-04 .15E-04 .2E-01 G .0E+00 .2E+00 14 23 .156E+03 .11E-06 .11E-06 .2E-02 G .0E+00 .2E-01 15 24 .156E+03 .83E-10 .74E-10 .2E-03 G .0E+00 .2E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .156435E+03 RELDX .189E-03 FUNC. EVALS 24 GRAD. EVALS 16 PRELDF .736E-10 NPRELDF .736E-10 I FINAL X(I) D(I) G(I) 1 .974671E-01 .386E+02 -.121E-04 2 .131572E+02 .264E+00 -.616E-07 3 .446198E+02 .627E-01 .799E-08 4 .691862E+00 .127E+01 -.487E-06 5 .154106E+02 .502E-01 -.129E-06 6 .135613E+01 .611E+00 -.159E-06 7 .327903E+02 .221E-01 .381E-08 8 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 8 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .86E-04 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .289E-01 ROW 2 -1.60 515. ROW 3 -4.65 .155E+04 .495E+04 ROW 4 -.873 -.567 -1.14 69.3 ROW 5 -15.6 -3.05 -8.09 .127E+04 .239E+05 ROW 6 -1.80 -1.08 -2.15 -.618E-01 -.383 287. ROW 7 -34.2 -5.46 -14.5 -.371 -3.43 .563E+04 .114E+06 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .118E-03 .267E-03 .360E-04 .241E-04 .291E-03 .466E-03 .938E-08 .438E-05 .149E-03 .259E-03 .366E-04 .780E-04 .339E-03 .709E-03 .336E-03 .112E-04 .405E-04 .735E-04 .286E-03 .467E-04 .194E-04 .809E-04 .129E-03 .351E-05 .200E-03 .268E-03 .418E-04 .132E-03 .104E-04 .916E-04 .238E-04 .406E-03 .122E-04 .570E-03 .243E-03 .202E-02 .610E-03 .308E-04 .513E-04 .122E-06 .197E-03 .460E-04 .321E-05 .341E-05 .275E-03 .373E-04 .992E-04 .113E-03 .745E-03 .374E-03 .985E-05 .216E-05 .398E-04 .631E-04 .603E-03 .388E-04 .307E-03 .113E-04 .444E-04 .317E-03 .328E-03 .237E-05 .492E-04 .143E-03 DEVIANCE = 1.96943890E-01 * 28 **** problem mn204 **** * 10 Example on p. 205 of McCullagh and Nelder * 7 Run 14: calling DGLG with PS = 4 I INITIAL X(I) D(I) 1 .100000E+01 .937E+01 2 .100000E+01 .176E+02 3 .100000E+01 .513E+01 4 .100000E+01 .582E+00 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .397E+04 1 5 .188E+04 .53E+00 .65E+00 .3E+00 G .1E+02 .1E+02 2 6 .150E+04 .20E+00 .23E+00 .7E+00 G .1E+00 .3E+02 3 8 .141E+04 .55E-01 .55E-01 .3E+00 G .1E-01 .4E+02 4 9 .136E+04 .39E-01 .36E-01 .3E+00 G .0E+00 .6E+02 5 10 .136E+04 .12E-02 .12E-02 .4E-01 G .0E+00 .1E+02 6 11 .136E+04 .21E-05 .21E-05 .2E-02 S .0E+00 .5E+00 7 12 .136E+04 .56E-11 .56E-11 .2E-05 S .0E+00 .7E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .135683E+04 RELDX .234E-05 FUNC. EVALS 12 GRAD. EVALS 8 PRELDF .556E-11 NPRELDF .556E-11 I FINAL X(I) D(I) G(I) 1 -.476241E+01 .214E+02 .421E-07 2 .202247E+01 .470E+02 .403E-07 3 .164300E+01 .108E+02 .307E-07 4 .176279E+01 .156E+01 .188E-07 5 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 5 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .21E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .527E-01 ROW 2 -.210E-01 .890E-02 ROW 3 -.193E-01 .683E-02 .275E-01 ROW 4 .173E-01 -.502E-02 .895E-01 .931 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .220 3.75 .125 .142 2.43 .358 .545 .163 .185 1.04 .301 .709E-01 1.11 .333 .106 DEVIANCE = 53.3353505 * 28 **** problem mn205 **** * 10 Example on p. 204-5 of McCullagh and Nelder * 7 Run 15: calling DGLG with PS = 5 I INITIAL X(I) D(I) 1 .100000E+01 .106E+02 2 .100000E+01 .171E+02 3 .100000E+01 .634E+01 4 .100000E+01 .716E+00 5 .100000E+01 .609E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .366E+04 1 4 .177E+04 .52E+00 .62E+00 .3E+00 G .9E+01 .1E+02 2 7 .152E+04 .14E+00 .13E+00 .9E-01 G .2E+01 .9E+01 3 11 .146E+04 .38E-01 .34E-01 .1E-01 G .2E+01 .5E+01 4 12 .140E+04 .45E-01 .44E-01 .1E-01 G .1E+00 .2E+02 5 14 .136E+04 .27E-01 .29E-01 .1E-01 G .3E-01 .3E+02 6 15 .134E+04 .10E-01 .14E-01 .3E-01 G .0E+00 .4E+02 7 16 .134E+04 .36E-02 .50E-02 .5E-01 G .0E+00 .3E+02 8 17 .134E+04 .32E-04 .33E-04 .7E-02 G .0E+00 .2E+01 9 18 .134E+04 .14E-08 .14E-08 .5E-04 G .0E+00 .1E-01 10 19 .134E+04 .76E-13 .76E-13 .5E-06 S .0E+00 .1E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .133952E+04 RELDX .477E-06 FUNC. EVALS 19 GRAD. EVALS 11 PRELDF .764E-13 NPRELDF .764E-13 I FINAL X(I) D(I) G(I) 1 -.289646E+01 .214E+02 -.165E-07 2 .134496E+01 .440E+02 .805E-07 3 .170841E+01 .982E+01 -.215E-07 4 .206105E+01 .140E+01 .151E-08 5 .167382E+01 .209E+02 .171E-06 6 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 6 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .22E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .613E-01 ROW 2 -.251E-01 .109E-01 ROW 3 -.135E-01 .480E-02 .310E-01 ROW 4 .254E-01 -.832E-02 .117 1.19 ROW 5 .216E-01 -.895E-02 -.585E-03 .752E-02 .126E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .641 2.70 .733E-01 .162E-01 1.08 1.07 .178 .466 .825E-01 .177 .176E-02 .154E-01 .276E-02 .460E-01 .199E-01 DEVIANCE = 18.6998888 * 28 **** problem mn205.1 **** * 10 Example on p. 205-6 of McCullagh and Nelder * 7 Run 16: calling DGLG with PS = 5 I INITIAL X(I) D(I) 1 -.289600E+01 .210E+02 2 .134500E+01 .431E+02 3 .170800E+01 .957E+01 4 .167400E+01 .151E+01 5 .198000E+01 .418E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .138E+04 1 2 .137E+04 .11E-01 .15E-01 .5E-02 G .3E+02 .9E+00 2 4 .135E+04 .11E-01 .17E-01 .1E-01 G .7E+01 .2E+01 3 5 .134E+04 .58E-02 .68E-02 .1E-01 G .1E+00 .8E+01 4 6 .134E+04 .26E-02 .33E-02 .3E-01 G .3E-01 .8E+01 5 7 .134E+04 .35E-03 .37E-03 .2E-01 G .0E+00 .7E+01 6 8 .134E+04 .44E-05 .45E-05 .3E-02 G .0E+00 .4E+00 7 9 .134E+04 .23E-09 .23E-09 .3E-04 G .0E+00 .5E-02 8 10 .134E+04 .31E-13 .32E-13 .3E-06 S .0E+00 .5E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .133952E+04 RELDX .307E-06 FUNC. EVALS 10 GRAD. EVALS 9 PRELDF .320E-13 NPRELDF .320E-13 I FINAL X(I) D(I) G(I) 1 -.289646E+01 .214E+02 -.495E-08 2 .134496E+01 .440E+02 -.292E-07 3 .170841E+01 .982E+01 -.116E-08 4 .206105E+01 .140E+01 -.803E-10 5 .167382E+01 .164E+02 -.171E-07 6 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 6 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .22E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .613E-01 ROW 2 -.251E-01 .109E-01 ROW 3 -.135E-01 .480E-02 .310E-01 ROW 4 .254E-01 -.832E-02 .117 1.19 ROW 5 .216E-01 -.895E-02 -.585E-03 .752E-02 .126E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .641 2.70 .733E-01 .162E-01 1.08 1.07 .178 .466 .825E-01 .177 .176E-02 .154E-01 .276E-02 .460E-01 .199E-01 DEVIANCE = 18.6998888 * 28 **** problem speed **** * 10 Speed data from Daryl(14.2): E(y)=b*x+c*x^2, var(y) = phi*E(y)^theta * 7 Run 17: calling DGLG with PS = 2 I INITIAL X(I) D(I) 1 .123903E+01 .115E+03 2 .901388E-01 .219E+04 3 .100000E+01 .104E+03 4 .000000E+00 .292E+03 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .546E+04 1 3 .525E+04 .39E-01 .39E-01 .5E-02 G .3E+02 .2E+01 2 6 .203E+04 .61E+00 .49E+00 .2E+00 G .0E+00 .7E+02 3 7 .834E+03 .59E+00 .47E+00 .2E+00 G .0E+00 .4E+02 4 8 .402E+03 .52E+00 .41E+00 .2E+00 G .0E+00 .3E+02 5 9 .253E+03 .37E+00 .30E+00 .1E+00 G .0E+00 .2E+02 6 10 .208E+03 .18E+00 .15E+00 .1E+00 G .0E+00 .8E+01 7 11 .198E+03 .46E-01 .39E-01 .6E-01 G .0E+00 .4E+01 8 12 .198E+03 .43E-02 .40E-02 .2E-01 G .0E+00 .1E+01 9 13 .198E+03 .15E-03 .12E-03 .1E-01 G .0E+00 .7E+00 10 14 .198E+03 .35E-04 .30E-04 .1E-01 G .0E+00 .6E+00 11 15 .198E+03 .35E-05 .32E-05 .3E-02 G .0E+00 .2E+00 12 16 .198E+03 .55E-07 .54E-07 .4E-03 G .0E+00 .3E-01 13 17 .198E+03 .18E-10 .18E-10 .8E-05 G .0E+00 .5E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .197503E+03 RELDX .757E-05 FUNC. EVALS 17 GRAD. EVALS 14 PRELDF .182E-10 NPRELDF .182E-10 I FINAL X(I) D(I) G(I) 1 .127462E+01 .765E+01 -.346E-10 2 .882812E-01 .125E+03 -.233E-08 3 .142511E+01 .351E+01 -.638E-07 4 .133148E+01 .180E+02 -.242E-06 5 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 5 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .57E-02 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .179 ROW 2 -.104E-01 .672E-03 ROW 3 .275E-01 -.168E-02 2.09 ROW 4 -.546E-02 .333E-03 -.400 .793E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .487 .501E-01 -1.00 .118 .636E-02 .310E-01 .777E-02 .838E-02 .600E-01 .125E-01 .587E-02 .378E-01 .974E-02 .576E-02 .477E-02 .569E-02 .505E-02 .505E-02 .230E-01 .696E-02 .498E-02 -1.00 -1.00 .388E-01 .106E-01 .139E-01 .667E-02 .520E-02 .122E-01 .539E-02 .609E-02 .629E-02 .674E-02 .383E-01 -1.00 .289E-01 .721E-02 .101E-01 -1.00 .100E-01 .767E-02 .706E-02 .768E-02 .851E-02 .415E-01 .147E-01 .158E-01 .171E-01 1.85 .103E-01 DEVIANCE = 71.2555697 * 28 **** problem textile **** * 10 textile data from Daryl: E(y) = exp(b0+x1*b1+x2*b2+x3*b3), Var(y) = mu^ * 7 Run 18: calling DGLG with PS = 4 I INITIAL X(I) D(I) 1 .633466E+01 .601E+04 2 .832384E+00 .553E+04 3 -.630992E+00 .535E+04 4 -.392494E+00 .512E+04 5 .100000E+01 .106E+04 6 .000000E+00 .563E+04 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .562E+06 1 4 .557E+06 .95E-02 .95E-02 .5E-04 G .2E+03 .5E+01 2 8 .403E+06 .28E+00 .27E+00 .2E-02 G .3E+01 .2E+03 3 9 .160E+06 .60E+00 .49E+00 .8E-02 G .8E-01 .5E+03 4 10 .592E+05 .63E+00 .50E+00 .1E-01 G .0E+00 .4E+03 5 11 .219E+05 .63E+00 .50E+00 .1E-01 G .0E+00 .3E+03 6 12 .817E+04 .63E+00 .50E+00 .1E-01 G .0E+00 .2E+03 7 13 .309E+04 .62E+00 .49E+00 .1E-01 G .0E+00 .9E+02 8 14 .122E+04 .61E+00 .48E+00 .1E-01 G .0E+00 .6E+02 9 15 .530E+03 .56E+00 .45E+00 .1E-01 G .0E+00 .3E+02 10 16 .282E+03 .47E+00 .37E+00 .1E-01 G .0E+00 .2E+02 11 17 .197E+03 .30E+00 .24E+00 .1E-01 G .0E+00 .1E+02 12 18 .171E+03 .13E+00 .11E+00 .8E-02 G .0E+00 .6E+01 13 19 .165E+03 .36E-01 .30E-01 .6E-02 G .0E+00 .3E+01 14 20 .164E+03 .68E-02 .54E-02 .5E-02 G .0E+00 .3E+01 15 23 .164E+03 .84E-03 .82E-03 .1E-02 G .4E+00 .5E+00 16 25 .164E+03 .12E-02 .12E-02 .2E-02 G .5E-01 .1E+01 17 27 .163E+03 .48E-03 .48E-03 .9E-03 G .4E+00 .4E+00 18 29 .163E+03 .99E-03 .99E-03 .2E-02 G .6E-01 .9E+00 19 31 .163E+03 .82E-03 .81E-03 .1E-02 G .2E+00 .7E+00 20 33 .163E+03 .17E-02 .18E-02 .3E-02 G .3E-01 .2E+01 21 35 .163E+03 .55E-03 .27E-02 .6E-02 G .3E-01 .3E+01 22 36 .162E+03 .46E-02 .39E-02 .4E-02 G .0E+00 .2E+01 23 39 .162E+03 .80E-03 .78E-03 .2E-02 G .1E+00 .9E+00 24 41 .162E+03 .13E-02 .16E-02 .4E-02 G .6E-01 .2E+01 25 42 .161E+03 .14E-02 .15E-02 .6E-02 G .0E+00 .3E+01 26 43 .161E+03 .20E-02 .16E-02 .4E-02 G .0E+00 .2E+01 27 45 .161E+03 .30E-03 .30E-03 .1E-02 G .2E+00 .5E+00 28 46 .161E+03 .54E-03 .55E-03 .2E-02 G .8E-01 .1E+01 29 48 .161E+03 .23E-03 .22E-03 .9E-03 G .2E+00 .4E+00 30 49 .161E+03 .40E-03 .40E-03 .2E-02 G .8E-01 .9E+00 31 51 .161E+03 .16E-03 .16E-03 .7E-03 G .2E+00 .3E+00 32 52 .161E+03 .29E-03 .30E-03 .1E-02 G .9E-01 .7E+00 33 54 .161E+03 .26E-03 .25E-03 .1E-02 G .9E-01 .6E+00 34 56 .161E+03 .43E-03 .48E-03 .2E-02 G .3E-01 .1E+01 35 57 .161E+03 .17E-03 .45E-03 .4E-02 G .0E+00 .2E+01 36 58 .161E+03 .76E-03 .68E-03 .2E-02 G .0E+00 .9E+00 37 60 .161E+03 .83E-04 .82E-04 .8E-03 G .6E-01 .5E+00 38 62 .161E+03 .13E-03 .14E-03 .2E-02 G .1E-01 .9E+00 39 63 .161E+03 .63E-04 .12E-03 .3E-02 G .0E+00 .2E+01 40 64 .161E+03 .15E-03 .14E-03 .1E-02 G .0E+00 .5E+00 41 66 .161E+03 .19E-04 .19E-04 .7E-03 G .1E-01 .4E+00 42 67 .161E+03 .12E-04 .12E-04 .8E-03 G .5E-02 .5E+00 43 68 .161E+03 .44E-05 .40E-05 .7E-03 G .0E+00 .4E+00 44 69 .161E+03 .45E-06 .42E-06 .2E-03 G .0E+00 .8E-01 45 70 .161E+03 .50E-08 .49E-08 .3E-04 G .0E+00 .2E-01 46 71 .161E+03 .27E-11 .28E-11 .1E-06 G .0E+00 .8E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .160510E+03 RELDX .141E-06 FUNC. EVALS 71 GRAD. EVALS 47 PRELDF .277E-11 NPRELDF .277E-11 I FINAL X(I) D(I) G(I) 1 .634775E+01 .332E+02 .139E-09 2 .840766E+00 .266E+02 -.213E-04 3 -.628736E+00 .267E+02 -.448E-05 4 -.370810E+00 .269E+02 -.371E-04 5 .122859E-02 .299E+04 -.579E-06 6 .248689E+01 .234E+02 -.884E-08 7 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 7 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .86E-03 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .109E-02 ROW 2 .394E-03 .156E-02 ROW 3 -.289E-03 .136E-04 .148E-02 ROW 4 -.155E-03 .136E-03 -.383E-04 .166E-02 ROW 5 .323E-05 -.285E-05 .866E-05 -.478E-04 .963E-05 ROW 6 -.415E-03 .366E-03 -.111E-02 .615E-02 -.122E-02 .157 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .996E-02 -1.00 .631E-01 .208E-01 .254E-01 -1.00 .174 .116 .968E-02 .179E-01 .237E-01 .561E-01 -1.00 .108E-01 .361E-01 .860E-02 .276E-01 .239E-01 .190E-01 .708 .708E-01 .423E-01 .511E-01 -1.00 .495E-01 -1.00 -1.00 DEVIANCE = 3.31717966E-02 * 28 **** problem insurance (D = I) **** * 10 Insurance data from Daryl. * 2 * 3 * 5 * 11 Changing RHO from 11 to 13 * 7 Run 19: calling DGLG with PS = 14 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .000000E+00 .100E+01 5 .000000E+00 .100E+01 6 .000000E+00 .100E+01 7 .000000E+00 .100E+01 8 .000000E+00 .100E+01 9 .000000E+00 .100E+01 10 .000000E+00 .100E+01 11 .000000E+00 .100E+01 12 .000000E+00 .100E+01 13 .000000E+00 .100E+01 14 .100000E+01 .100E+01 15 .100000E+01 .100E+01 16 .200000E+01 .100E+01 17 -.100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .210E+07 1 3 .643E+06 .69E+00 .82E+00 .7E-01 G .8E+07 .5E+00 2 5 .180E+06 .72E+00 .76E+00 .4E-01 G .6E+07 .3E+00 3 9 .105E+06 .42E+00 .42E+00 .1E-01 G .1E+08 .7E-01 4 14 .969E+05 .74E-01 .74E-01 .2E-02 G .8E+08 .1E-01 5 18 .950E+05 .19E-01 .19E-01 .4E-03 G .3E+09 .2E-02 6 22 .946E+05 .46E-02 .47E-02 .1E-03 G .1E+10 .6E-03 7 26 .829E+05 .12E+00 .12E+00 .3E-02 G .5E+07 .2E-01 8 28 .644E+05 .22E+00 .22E+00 .6E-02 G .1E+08 .4E-01 9 32 .602E+05 .65E-01 .65E-01 .2E-02 G .4E+08 .1E-01 10 34 .528E+05 .12E+00 .12E+00 .3E-02 G .3E+07 .2E-01 11 39 .512E+05 .30E-01 .30E-01 .7E-03 G .7E+08 .5E-02 12 41 .485E+05 .54E-01 .54E-01 .1E-02 G .7E+07 .9E-02 13 43 .395E+05 .19E+00 .19E+00 .5E-02 G .8E+06 .3E-01 14 45 .535E+04 .86E+00 .92E+00 .4E-01 G .2E+06 .3E+00 15 47 .111E+04 .79E+00 .85E+00 .2E-01 G .9E+05 .2E+00 16 49 .814E+03 .27E+00 .28E+00 .1E-01 G .2E+05 .8E-01 17 50 .680E+03 .17E+00 .21E+00 .1E-01 G .2E+05 .8E-01 18 51 .656E+03 .35E-01 .44E-01 .2E-01 G .3E+04 .9E-01 19 52 .637E+03 .30E-01 .35E-01 .2E-01 G .3E+04 .9E-01 20 53 .624E+03 .19E-01 .22E-01 .2E-01 G .1E+04 .9E-01 21 54 .622E+03 .43E-02 .58E-02 .2E-01 G .4E+02 .9E-01 22 55 .621E+03 .67E-03 .63E-03 .2E-01 G .7E+01 .9E-01 23 56 .621E+03 .16E-03 .15E-03 .2E-01 G .1E+02 .9E-01 24 58 .621E+03 .14E-03 .14E-03 .2E-01 G .1E+02 .8E-01 25 59 .621E+03 .25E-03 .29E-03 .4E-01 G .7E+01 .2E+00 26 61 .621E+03 .24E-03 .20E-03 .2E-01 G .7E+01 .1E+00 27 63 .621E+03 .19E-03 .19E-03 .2E-01 G .1E+01 .1E+00 28 64 .621E+03 .14E-03 .15E-03 .2E-01 G .0E+00 .1E+00 29 65 .620E+03 .18E-03 .15E-03 .7E-02 G .0E+00 .4E-01 30 67 .620E+03 .25E-04 .25E-04 .2E-02 G .7E+02 .1E-01 31 69 .620E+03 .54E-04 .65E-04 .7E-02 G .2E+02 .4E-01 32 70 .620E+03 .47E-04 .39E-04 .7E-02 G .0E+00 .4E-01 33 71 .620E+03 .12E-04 .21E-04 .4E-02 G .0E+00 .3E-01 34 72 .620E+03 .23E-04 .21E-04 .3E-02 G .0E+00 .2E-01 35 74 .620E+03 .27E-05 .27E-05 .1E-02 G .4E+02 .5E-02 36 76 .620E+03 .19E-05 .19E-05 .1E-02 G .6E+01 .5E-02 37 78 .620E+03 .13E-05 .12E-05 .7E-03 G .5E+02 .4E-02 38 80 .620E+03 .20E-05 .21E-05 .1E-02 G .1E+02 .7E-02 39 82 .620E+03 .22E-05 .20E-05 .1E-02 G .1E+02 .7E-02 40 83 .620E+03 .21E-05 .18E-05 .2E-02 G .1E+02 .7E-02 41 84 .620E+03 .17E-05 .18E-05 .2E-02 G .0E+00 .1E-01 42 85 .620E+03 .26E-05 .21E-05 .1E-02 G .0E+00 .5E-02 43 87 .620E+03 .12E-05 .12E-05 .1E-02 G .2E+02 .6E-02 44 89 .620E+03 .12E-05 .11E-05 .1E-02 G .0E+00 .6E-02 45 91 .620E+03 .11E-05 .10E-05 .1E-02 G .1E+02 .6E-02 46 93 .620E+03 .97E-06 .88E-06 .1E-02 G .0E+00 .5E-02 47 95 .620E+03 .86E-06 .79E-06 .1E-02 G .1E+02 .5E-02 48 97 .620E+03 .76E-06 .70E-06 .1E-02 G .0E+00 .5E-02 49 99 .620E+03 .64E-06 .60E-06 .9E-03 G .1E+02 .4E-02 50 100 .620E+03 .71E-06 .91E-06 .2E-02 G .5E+01 .9E-02 51 101 .620E+03 .91E-06 .69E-06 .1E-02 G .0E+00 .5E-02 52 102 .620E+03 .49E-06 .62E-06 .2E-02 G .2E+01 .9E-02 53 103 .620E+03 .69E-06 .55E-06 .8E-03 G .0E+00 .4E-02 54 104 .620E+03 .26E-06 .46E-06 .2E-02 G .2E+01 .9E-02 55 105 .620E+03 .51E-06 .44E-06 .6E-03 G .0E+00 .3E-02 56 106 .620E+03 .64E-07 .32E-06 .2E-02 G .1E+01 .9E-02 57 107 .620E+03 .39E-06 .37E-06 .4E-03 G .0E+00 .2E-02 58 109 .620E+03 .91E-07 .92E-07 .7E-03 G .4E+01 .3E-02 59 110 .620E+03 .75E-07 .69E-07 .7E-03 G .2E+01 .3E-02 60 111 .620E+03 .53E-07 .54E-07 .1E-02 G .0E+00 .5E-02 61 112 .620E+03 .43E-07 .37E-07 .3E-03 G .0E+00 .2E-02 62 113 .620E+03 .11E-07 .14E-07 .7E-03 G .0E+00 .3E-02 63 114 .620E+03 .68E-08 .65E-08 .1E-03 G .0E+00 .5E-03 64 115 .620E+03 .32E-09 .32E-09 .1E-03 G .0E+00 .6E-03 65 116 .620E+03 .60E-11 .60E-11 .3E-05 G .0E+00 .2E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .620375E+03 RELDX .343E-05 FUNC. EVALS 116 GRAD. EVALS 66 PRELDF .598E-11 NPRELDF .598E-11 I FINAL X(I) D(I) G(I) 1 -.205141E-02 .100E+01 .565E-04 2 -.198125E-02 .100E+01 .387E-04 3 -.111200E-02 .100E+01 .566E-05 4 -.531678E-03 .100E+01 -.329E-05 5 .241718E-02 .100E+01 .523E-05 6 .122307E-02 .100E+01 -.548E-04 7 .979342E-03 .100E+01 -.299E-04 8 .182946E-02 .100E+01 .181E-04 9 .185834E-02 .100E+01 -.110E-03 10 -.371478E-03 .100E+01 -.781E-04 11 -.480743E-02 .100E+01 -.233E-03 12 -.360719E-02 .100E+01 -.175E-03 13 .537430E-03 .100E+01 -.212E-04 14 .223880E-01 .100E+01 -.479E-03 15 .111635E+00 .100E+01 -.336E-07 16 .241031E+01 .100E+01 -.205E-07 17 -.139646E+01 .100E+01 -.256E-04 18 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 18 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .13E-03 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .189E-04 ROW 2 .173E-04 .181E-04 ROW 3 .979E-05 .101E-04 .598E-05 ROW 4 .409E-05 .432E-05 .249E-05 .125E-05 ROW 5 -.206E-04 -.206E-04 -.118E-04 -.506E-05 .242E-04 ROW 6 -.110E-04 -.110E-04 -.624E-05 -.267E-05 .128E-04 .690E-05 ROW 7 -.874E-05 -.864E-05 -.491E-05 -.210E-05 .101E-04 .536E-05 .434E-05 ROW 8 -.162E-04 -.164E-04 -.936E-05 -.401E-05 .191E-04 .101E-04 .797E-05 .153E-04 ROW 9 -.161E-04 -.163E-04 -.931E-05 -.400E-05 .190E-04 .101E-04 .794E-05 .150E-04 .151E-04 ROW 10 .287E-05 .290E-05 .165E-05 .709E-06 -.338E-05 -.180E-05 -.141E-05 -.272E-05 -.267E-05 .541E-06 ROW 11 .382E-04 .386E-04 .221E-04 .947E-05 -.449E-04 -.239E-04 -.188E-04 -.357E-04 -.355E-04 .631E-05 .842E-04 ROW 12 .280E-04 .283E-04 .162E-04 .695E-05 -.330E-04 -.175E-04 -.138E-04 -.262E-04 -.261E-04 .463E-05 .618E-04 .454E-04 ROW 13 -.578E-05 -.585E-05 -.334E-05 -.143E-05 .681E-05 .362E-05 .284E-05 .540E-05 .538E-05 -.956E-06 -.128E-04 -.936E-05 .220E-05 ROW 14 -.245E-03 -.248E-03 -.142E-03 -.608E-04 .288E-03 .153E-03 .121E-03 .229E-03 .228E-03 -.406E-04 -.540E-03 -.396E-03 .818E-04 .346E-02 ROW 15 .257E-04 .404E-04 .277E-04 .448E-05 -.351E-04 -.245E-04 -.164E-04 -.383E-04 -.318E-04 .772E-05 .749E-04 .583E-04 -.992E-05 -.500E-03 .240E-01 ROW 16 -.432E-04 -.681E-04 -.466E-04 -.756E-05 .592E-04 .412E-04 .275E-04 .645E-04 .535E-04 -.130E-04 -.126E-03 -.982E-04 .167E-04 .842E-03 -.399E-01 .671E-01 ROW 17 .407E-02 .411E-02 .235E-02 .101E-02 -.479E-02 -.255E-02 -.200E-02 -.381E-02 -.379E-02 .674E-03 .897E-02 .658E-02 -.136E-02 -.576E-01 .831E-02 -.140E-01 .957 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .248E-02 .650E-01 -1.00 .317E-01 .436E-02 -1.00 -1.00 -1.00 .237E-02 .178E-01 .742E-01 -1.00 -1.00 .933E-02 -1.00 .362E-02 -1.00 -1.00 .686E-01 -1.00 .127 -1.00 -1.00 -1.00 .388E-01 -1.00 -1.00 .260 .115 -1.00 .326E-02 .773E-01 .456E-02 -1.00 -1.00 .364E-01 -1.00 -1.00 .352E-01 -1.00 .102 -1.00 -1.00 -1.00 .714E-01 -1.00 -1.00 -1.00 -1.00 -1.00 .274E-01 .713E-01 .539E-02 .371E-02 .522E-01 -1.00 .740E-01 -1.00 .559E-02 -1.00 -1.00 -1.00 .285E-01 .389E-02 -1.00 .287E-02 -1.00 -1.00 .200E-02 .959E-02 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 .225E-02 -1.00 .423E-01 .202E-02 -1.00 .296E-01 -1.00 .191E-01 .469E-02 -1.00 -1.00 .458E-01 .228E-02 .423E-01 .226E-01 -1.00 .206E-02 -1.00 .370E-02 .219E-02 -1.00 -1.00 -1.00 .250E-02 -1.00 -1.00 -1.00 -1.00 -1.00 .272E-02 .743E-01 .469E-02 -1.00 -1.00 .232E-02 -1.00 -1.00 .744E-01 .117E-01 .200E-02 -1.00 -1.00 -1.00 -1.00 DEVIANCE = 13.7311100 * 28 **** problem insurance.1 (D = I) **** * 5 * 7 Run 20: calling DGLG with PS = 14 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .000000E+00 .100E+01 5 .000000E+00 .100E+01 6 .000000E+00 .100E+01 7 .000000E+00 .100E+01 8 .000000E+00 .100E+01 9 .000000E+00 .100E+01 10 .000000E+00 .100E+01 11 .000000E+00 .100E+01 12 .000000E+00 .100E+01 13 .000000E+00 .100E+01 14 .100000E+01 .100E+01 15 .100000E+01 .100E+01 16 .150000E+01 .100E+01 17 -.100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .379E+07 1 3 .133E+07 .65E+00 .64E+00 .1E+00 G .8E+07 .5E+00 2 7 .729E+06 .45E+00 .46E+00 .3E-01 G .2E+08 .2E+00 3 10 .450E+06 .38E+00 .39E+00 .2E-01 G .4E+08 .9E-01 4 14 .381E+06 .15E+00 .15E+00 .5E-02 G .1E+09 .2E-01 5 18 .365E+06 .43E-01 .43E-01 .1E-02 G .4E+09 .6E-02 6 21 .357E+06 .21E-01 .21E-01 .6E-03 G .8E+09 .3E-02 7 24 .308E+06 .14E+00 .14E+00 .4E-02 G .1E+08 .3E-01 8 27 .265E+06 .14E+00 .14E+00 .4E-02 G .7E+08 .2E-01 9 29 .228E+06 .14E+00 .14E+00 .4E-02 G .6E+08 .2E-01 10 31 .170E+06 .26E+00 .26E+00 .8E-02 G .4E+07 .5E-01 11 33 .886E+05 .48E+00 .52E+00 .2E-01 G .6E+07 .1E+00 12 37 .792E+05 .11E+00 .10E+00 .2E-02 G .3E+08 .2E-01 13 39 .728E+05 .81E-01 .85E-01 .2E-02 G .6E+07 .2E-01 14 41 .604E+05 .17E+00 .17E+00 .5E-02 G .1E+07 .4E-01 15 44 .494E+05 .18E+00 .18E+00 .6E-02 G .5E+07 .5E-01 16 46 .330E+05 .33E+00 .33E+00 .1E-01 G .3E+06 .9E-01 17 48 .989E+04 .70E+00 .75E+00 .3E-01 G .5E+06 .2E+00 18 50 .280E+04 .72E+00 .74E+00 .1E-01 G .5E+06 .1E+00 19 52 .116E+04 .59E+00 .70E+00 .7E-02 G .4E+06 .6E-01 20 54 .712E+03 .39E+00 .35E+00 .7E-02 G .2E+06 .3E-01 21 55 .641E+03 .10E+00 .14E+00 .5E-02 G .3E+05 .3E-01 22 56 .624E+03 .25E-01 .23E-01 .7E-02 G .5E+04 .3E-01 23 57 .622E+03 .42E-02 .46E-02 .8E-02 G .9E+03 .3E-01 24 58 .622E+03 .16E-03 .16E-03 .8E-02 G .3E+02 .3E-01 25 61 .621E+03 .18E-03 .18E-03 .3E-01 G .2E+01 .1E+00 26 63 .621E+03 .16E-03 .16E-03 .3E-01 G .8E+01 .1E+00 27 65 .621E+03 .31E-03 .34E-03 .5E-01 G .1E+01 .2E+00 28 67 .621E+03 .16E-03 .15E-03 .1E-01 G .1E+02 .6E-01 29 69 .621E+03 .12E-03 .12E-03 .1E-01 G .5E+01 .6E-01 30 71 .621E+03 .17E-03 .17E-03 .2E-01 G .1E+02 .9E-01 31 72 .621E+03 .11E-03 .32E-03 .4E-01 G .5E+01 .2E+00 32 73 .621E+03 .37E-03 .32E-03 .8E-02 G .0E+00 .5E-01 33 75 .621E+03 .40E-04 .39E-04 .3E-02 G .7E+02 .2E-01 34 77 .621E+03 .83E-04 .87E-04 .8E-02 G .3E+02 .4E-01 35 79 .621E+03 .37E-04 .36E-04 .3E-02 G .6E+02 .2E-01 36 81 .620E+03 .78E-04 .92E-04 .9E-02 G .2E+02 .5E-01 37 82 .620E+03 .63E-04 .60E-04 .8E-02 G .0E+00 .6E-01 38 83 .620E+03 .52E-04 .43E-04 .5E-02 G .0E+00 .3E-01 39 84 .620E+03 .59E-06 .16E-04 .6E-02 G .0E+00 .4E-01 40 85 .620E+03 .23E-04 .22E-04 .1E-02 G .0E+00 .7E-02 41 87 .620E+03 .43E-06 .43E-06 .5E-03 G .2E+02 .3E-02 42 89 .620E+03 .42E-06 .45E-06 .1E-02 G .6E+01 .6E-02 43 90 .620E+03 .24E-06 .23E-06 .1E-02 G .0E+00 .7E-02 44 91 .620E+03 .21E-06 .17E-06 .6E-03 G .0E+00 .3E-02 45 92 .620E+03 .12E-07 .12E-06 .2E-02 G .0E+00 .8E-02 46 93 .620E+03 .19E-06 .18E-06 .2E-03 G .0E+00 .1E-02 47 94 .620E+03 .31E-07 .39E-07 .8E-03 G .1E+01 .4E-02 48 95 .620E+03 .19E-07 .16E-07 .3E-03 G .0E+00 .2E-02 49 96 .620E+03 .50E-08 .48E-08 .4E-03 G .0E+00 .2E-02 50 97 .620E+03 .98E-09 .92E-09 .8E-04 G .0E+00 .4E-03 51 98 .620E+03 .26E-10 .25E-10 .3E-04 G .0E+00 .2E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .620375E+03 RELDX .336E-04 FUNC. EVALS 98 GRAD. EVALS 52 PRELDF .253E-10 NPRELDF .253E-10 I FINAL X(I) D(I) G(I) 1 -.205140E-02 .100E+01 .502E-02 2 -.198124E-02 .100E+01 .345E-02 3 -.111199E-02 .100E+01 .525E-03 4 -.531676E-03 .100E+01 -.271E-03 5 .241717E-02 .100E+01 .461E-03 6 .122307E-02 .100E+01 -.486E-02 7 .979337E-03 .100E+01 -.265E-02 8 .182945E-02 .100E+01 .155E-02 9 .185833E-02 .100E+01 -.985E-02 10 -.371477E-03 .100E+01 -.695E-02 11 -.480741E-02 .100E+01 -.206E-01 12 -.360718E-02 .100E+01 -.156E-01 13 .537427E-03 .100E+01 -.188E-02 14 .223879E-01 .100E+01 -.425E-01 15 .111635E+00 .100E+01 -.181E-06 16 .241031E+01 .100E+01 -.933E-07 17 -.139646E+01 .100E+01 -.234E-02 18 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 18 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .13E-03 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .188E-04 ROW 2 .172E-04 .181E-04 ROW 3 .976E-05 .101E-04 .596E-05 ROW 4 .407E-05 .430E-05 .248E-05 .125E-05 ROW 5 -.206E-04 -.206E-04 -.117E-04 -.504E-05 .241E-04 ROW 6 -.110E-04 -.109E-04 -.622E-05 -.266E-05 .127E-04 .688E-05 ROW 7 -.871E-05 -.861E-05 -.490E-05 -.209E-05 .100E-04 .534E-05 .433E-05 ROW 8 -.162E-04 -.163E-04 -.933E-05 -.400E-05 .190E-04 .101E-04 .795E-05 .152E-04 ROW 9 -.161E-04 -.163E-04 -.928E-05 -.399E-05 .189E-04 .101E-04 .791E-05 .150E-04 .150E-04 ROW 10 .287E-05 .289E-05 .165E-05 .706E-06 -.337E-05 -.179E-05 -.141E-05 -.271E-05 -.267E-05 .540E-06 ROW 11 .381E-04 .385E-04 .220E-04 .944E-05 -.448E-04 -.238E-04 -.187E-04 -.356E-04 -.354E-04 .629E-05 .840E-04 ROW 12 .279E-04 .282E-04 .161E-04 .693E-05 -.329E-04 -.175E-04 -.137E-04 -.261E-04 -.260E-04 .462E-05 .616E-04 .452E-04 ROW 13 -.576E-05 -.583E-05 -.333E-05 -.143E-05 .679E-05 .360E-05 .284E-05 .538E-05 .536E-05 -.953E-06 -.127E-04 -.933E-05 .219E-05 ROW 14 -.244E-03 -.247E-03 -.141E-03 -.606E-04 .287E-03 .153E-03 .120E-03 .228E-03 .227E-03 -.404E-04 -.538E-03 -.395E-03 .815E-04 .345E-02 ROW 15 .252E-04 .400E-04 .275E-04 .437E-05 -.346E-04 -.242E-04 -.161E-04 -.379E-04 -.314E-04 .765E-05 .740E-04 .576E-04 -.978E-05 -.494E-03 .239E-01 ROW 16 -.425E-04 -.673E-04 -.462E-04 -.738E-05 .583E-04 .408E-04 .272E-04 .638E-04 .529E-04 -.129E-04 -.125E-03 -.970E-04 .165E-04 .832E-03 -.399E-01 .671E-01 ROW 17 .406E-02 .410E-02 .234E-02 .101E-02 -.478E-02 -.254E-02 -.200E-02 -.379E-02 -.378E-02 .672E-03 .894E-02 .656E-02 -.135E-02 -.574E-01 .821E-02 -.138E-01 .954 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .248E-02 .650E-01 -1.00 .317E-01 .436E-02 -1.00 -1.00 -1.00 .237E-02 .178E-01 .742E-01 -1.00 -1.00 .933E-02 -1.00 .362E-02 -1.00 -1.00 .686E-01 -1.00 .127 -1.00 -1.00 -1.00 .388E-01 -1.00 -1.00 .260 .115 -1.00 .326E-02 .773E-01 .456E-02 -1.00 -1.00 .364E-01 -1.00 -1.00 .352E-01 -1.00 .102 -1.00 -1.00 -1.00 .714E-01 -1.00 -1.00 -1.00 -1.00 -1.00 .274E-01 .713E-01 .539E-02 .371E-02 .522E-01 -1.00 .740E-01 -1.00 .559E-02 -1.00 -1.00 -1.00 .285E-01 .389E-02 -1.00 .287E-02 -1.00 -1.00 .200E-02 .959E-02 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 -1.00 .225E-02 -1.00 .423E-01 .202E-02 -1.00 .296E-01 -1.00 .191E-01 .469E-02 -1.00 -1.00 .458E-01 .228E-02 .423E-01 .226E-01 -1.00 .206E-02 -1.00 .370E-02 .219E-02 -1.00 -1.00 -1.00 .250E-02 -1.00 -1.00 -1.00 -1.00 -1.00 .272E-02 .743E-01 .469E-02 -1.00 -1.00 .232E-02 -1.00 -1.00 .744E-01 .117E-01 .200E-02 -1.00 -1.00 -1.00 -1.00 DEVIANCE = 13.7311123 //GO.SYSIN DD pmain.sgi cat >rent1.sgi <<'//GO.SYSIN DD rent1.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 21 FIXED BLOCK SIZE: 27 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .84E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .35E-03 .41E-03 .2E-01 G .0E+00 .8E-01 3 4 .415E+03 .15E-04 .15E-04 .3E-02 S .0E+00 .1E-01 4 5 .415E+03 .14E-06 .15E-06 .3E-03 S .0E+00 .1E-02 5 6 .415E+03 .22E-08 .22E-08 .3E-04 S .0E+00 .2E-03 6 7 .415E+03 .40E-10 .41E-10 .5E-05 S .0E+00 .2E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .414996E+03 RELDX .468E-05 FUNC. EVALS 7 GRAD. EVALS 7 PRELDF .405E-10 NPRELDF .405E-10 I FINAL X(I) D(I) G(I) 1 -.417176E-02 .100E+01 .690E-02 2 .309495E-02 .100E+01 .151E-03 3 -.415382E+00 .100E+01 -.616E-04 4 .805209E+00 .100E+01 .626E-05 5 .739921E+00 .100E+01 .104E-03 6 -.156055E+01 .100E+01 .931E-04 7 -.704689E+00 .100E+01 -.196E-03 8 .541099E+00 .100E+01 -.279E-03 9 .102279E+01 .100E+01 .237E-03 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .15E-02 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .122E-06 ROW 2 .637E-05 .139E-01 ROW 3 .774E-05 .743E-02 .206E-01 ROW 4 -.484E-05 .946E-03 -.166E-02 .197E-01 ROW 5 -.615E-05 .153E-03 -.299E-02 .107E-01 .183E-01 ROW 6 .189E-04 -.847E-03 -.108E-02 -.475E-02 -.601E-02 .229E-01 ROW 7 .906E-05 .105E-02 .159E-02 -.912E-03 -.111E-02 .638E-02 .126E-01 ROW 8 -.187E-04 .155E-02 -.126E-02 .220E-02 .379E-02 -.303E-02 -.224E-02 .156E-01 ROW 9 -.121E-04 -.396E-03 .101E-03 .321E-02 .449E-03 -.396E-02 -.127E-02 .622E-02 .930E-02 BLOCK REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * BLOCK FIRST LAST RD(I) X(I) 1 1 27 1.37 -.432036E-02 .689006E-02 -.454742 .750261 .706886 -1.40656 -.688481 .532909 1.05724 2 28 54 1.35 -.395289E-02 .671261E-01 -.401830 .934179 .764509 -1.49978 -.607417 .491203 1.05807 3 55 81 2.28 -.398184E-02 .891929E-01 -.432253 .718803 .592961 -1.58360 -.629194 .464618 1.07271 4 82 108 .782 -.418353E-02 -.479047E-01 -.443015 .860322 .829490 -1.48508 -.641022 .527859 .977591 5 109 135 .392 -.416660E-02 -.198888E-01 -.473270 .723134 .657318 -1.52645 -.718463 .549875 1.03077 6 136 162 .733 -.422015E-02 .369010E-01 -.370415 .864933 .794825 -1.49062 -.624311 .541274 .988646 7 163 189 .574 -.401476E-02 .216232E-01 -.333111 .844806 .787417 -1.52104 -.683333 .569935 1.05228 8 190 216 .205 -.412189E-02 .302135E-02 -.392088 .756986 .671126 -1.50307 -.708418 .505785 .999088 9 217 243 2.02 -.420588E-02 -.531854E-01 -.384752 .854976 .722049 -1.72319 -.710096 .594931 1.00716 10 244 270 .517 -.413471E-02 -.811882E-01 -.426687 .812327 .754296 -1.61269 -.710099 .537952 1.00783 11 271 297 .397 -.426569E-02 -.745963E-01 -.476782 .828184 .772109 -1.52991 -.708157 .589738 1.05453 12 298 324 .793 -.415671E-02 .640466E-01 -.342630 .803615 .676671 -1.55464 -.767174 .580018 .998304 13 325 351 .179 -.407196E-02 .137638E-01 -.424388 .754705 .720375 -1.50624 -.664943 .526233 1.01178 14 352 378 23.2 -.520847E-02 .213824 -.296681 .977017 1.08571 -2.15517 -1.10519 .589033 1.32706 15 379 405 .303 -.412018E-02 .369619E-02 -.379747 .749824 .705542 -1.51105 -.698940 .469147 .981475 16 406 432 1.03 -.417479E-02 -.789858E-01 -.454166 .883726 .836766 -1.52686 -.704554 .467903 .953507 17 433 459 2.42 -.426903E-02 .919139E-01 -.269440 .721690 .799428 -1.74527 -.692543 .635327 1.00821 18 460 486 .295 -.408597E-02 -.236990E-01 -.455794 .750614 .708528 -1.52053 -.739287 .533722 1.02839 19 487 513 8.07 -.441734E-02 .487605E-01 -.774982 .889980 .779335 -1.83375 -.768117 .681128 .998395 20 514 540 .445 -.439653E-02 -.219163E-01 -.375853 .822584 .734316 -1.56971 -.726309 .532129 1.04606 21 541 567 .502 -.408978E-02 -.340176E-01 -.413135 .796396 .693248 -1.52454 -.755420 .547292 .989835 ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 RENT -.417176E-02 -.119269E+02 .349776E-03 2 LocD1 .309495E-02 .262612E-01 .117853E+00 3 LocD2 -.415382E+00 -.289367E+01 .143548E+00 4 ConD1 .805209E+00 .573979E+01 .140286E+00 5 ConD2 .739921E+00 .546424E+01 .135412E+00 6 BedD1 -.156055E+01 -.103182E+02 .151244E+00 7 BedD2 -.704689E+00 -.628199E+01 .112176E+00 8 Htype .541099E+00 .433083E+01 .124941E+00 9 CDum .102279E+01 .106073E+02 .964229E-01 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.414996E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415834E+03 1 - L(EST)/L(0): = .333782E+00 1 - (L(EST)-NPAR)/L(0) = .319334E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301438E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.417176E-02 -.100000E+03 .100000E+03 LocD1 .309495E-02 -.100000E+03 .100000E+03 LocD2 -.415382E+00 -.100000E+03 .100000E+03 ConD1 .805209E+00 -.100000E+03 .100000E+03 ConD2 .739921E+00 -.100000E+03 .100000E+03 BedD1 -.156055E+01 -.100000E+03 .100000E+03 BedD2 -.704689E+00 -.100000E+03 .100000E+03 Htype .541099E+00 -.100000E+03 .100000E+03 CDum .102279E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD rent1.sgi cat >rent1b.sgi <<'//GO.SYSIN DD rent1b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 21 FIXED BLOCK SIZE: 27 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .84E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .35E-03 .41E-03 .2E-01 G .0E+00 .8E-01 3 4 .415E+03 .15E-04 .15E-04 .3E-02 S .0E+00 .1E-01 4 5 .415E+03 .14E-06 .15E-06 .3E-03 S .0E+00 .1E-02 5 6 .415E+03 .22E-08 .22E-08 .3E-04 S .0E+00 .2E-03 6 7 .415E+03 .40E-10 .41E-10 .5E-05 S .0E+00 .2E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .414996E+03 RELDX .468E-05 FUNC. EVALS 7 GRAD. EVALS 7 PRELDF .405E-10 NPRELDF .405E-10 I FINAL X(I) D(I) G(I) 1 -.417176E-02 .100E+01 .690E-02 2 .309495E-02 .100E+01 .151E-03 3 -.415382E+00 .100E+01 -.615E-04 4 .805209E+00 .100E+01 .614E-05 5 .739921E+00 .100E+01 .104E-03 6 -.156055E+01 .100E+01 .933E-04 7 -.704689E+00 .100E+01 -.197E-03 8 .541099E+00 .100E+01 -.279E-03 9 .102279E+01 .100E+01 .238E-03 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.414996E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415834E+03 1 - L(EST)/L(0): = .333782E+00 1 - (L(EST)-NPAR)/L(0) = .319334E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301438E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.417176E-02 -.100000E+03 .100000E+03 LocD1 .309495E-02 -.100000E+03 .100000E+03 LocD2 -.415382E+00 -.100000E+03 .100000E+03 ConD1 .805209E+00 -.100000E+03 .100000E+03 ConD2 .739921E+00 -.100000E+03 .100000E+03 BedD1 -.156055E+01 -.100000E+03 .100000E+03 BedD2 -.704689E+00 -.100000E+03 .100000E+03 Htype .541099E+00 -.100000E+03 .100000E+03 CDum .102279E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD rent1b.sgi cat >rent2.sgi <<'//GO.SYSIN DD rent2.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 3 VARIABLE BLOCK-SIZE OPTION CHOSEN BLOCK-SIZES: 216 162 189 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .84E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .35E-03 .41E-03 .2E-01 G .0E+00 .8E-01 3 4 .415E+03 .15E-04 .15E-04 .3E-02 S .0E+00 .1E-01 4 5 .415E+03 .14E-06 .15E-06 .3E-03 S .0E+00 .1E-02 5 6 .415E+03 .22E-08 .22E-08 .3E-04 S .0E+00 .2E-03 6 7 .415E+03 .40E-10 .41E-10 .5E-05 S .0E+00 .2E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .414996E+03 RELDX .468E-05 FUNC. EVALS 7 GRAD. EVALS 7 PRELDF .405E-10 NPRELDF .405E-10 I FINAL X(I) D(I) G(I) 1 -.417176E-02 .100E+01 .690E-02 2 .309495E-02 .100E+01 .151E-03 3 -.415382E+00 .100E+01 -.616E-04 4 .805209E+00 .100E+01 .626E-05 5 .739921E+00 .100E+01 .104E-03 6 -.156055E+01 .100E+01 .931E-04 7 -.704689E+00 .100E+01 -.196E-03 8 .541099E+00 .100E+01 -.279E-03 9 .102279E+01 .100E+01 .237E-03 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .15E-02 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .122E-06 ROW 2 .637E-05 .139E-01 ROW 3 .774E-05 .743E-02 .206E-01 ROW 4 -.484E-05 .946E-03 -.166E-02 .197E-01 ROW 5 -.615E-05 .153E-03 -.299E-02 .107E-01 .183E-01 ROW 6 .189E-04 -.847E-03 -.108E-02 -.475E-02 -.601E-02 .229E-01 ROW 7 .906E-05 .105E-02 .159E-02 -.912E-03 -.111E-02 .638E-02 .126E-01 ROW 8 -.187E-04 .155E-02 -.126E-02 .220E-02 .379E-02 -.303E-02 -.224E-02 .156E-01 ROW 9 -.121E-04 -.396E-03 .101E-03 .321E-02 .449E-03 -.396E-02 -.127E-02 .622E-02 .930E-02 BLOCK REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * BLOCK FIRST LAST RD(I) X(I) 1 1 216 18.3 -.363145E-02 .189900 -.426132 .824762 .551742 -.969218 -.264445 .333277 1.10424 2 217 378 13.4 -.504620E-02 -.483437E-01 -.272364 1.00634 .948275 -2.22987 -1.07307 .739034 1.25642 3 379 567 7.97 -.448066E-02 -.114760E-01 -.576371 .687746 .792413 -1.83698 -.870788 .577961 .816514 ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 RENT -.417176E-02 -.119269E+02 .349776E-03 2 LocD1 .309495E-02 .262612E-01 .117853E+00 3 LocD2 -.415382E+00 -.289367E+01 .143548E+00 4 ConD1 .805209E+00 .573979E+01 .140286E+00 5 ConD2 .739921E+00 .546424E+01 .135412E+00 6 BedD1 -.156055E+01 -.103182E+02 .151244E+00 7 BedD2 -.704689E+00 -.628199E+01 .112176E+00 8 Htype .541099E+00 .433083E+01 .124941E+00 9 CDum .102279E+01 .106073E+02 .964229E-01 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.414996E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415834E+03 1 - L(EST)/L(0): = .333782E+00 1 - (L(EST)-NPAR)/L(0) = .319334E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301438E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.417176E-02 -.100000E+03 .100000E+03 LocD1 .309495E-02 -.100000E+03 .100000E+03 LocD2 -.415382E+00 -.100000E+03 .100000E+03 ConD1 .805209E+00 -.100000E+03 .100000E+03 ConD2 .739921E+00 -.100000E+03 .100000E+03 BedD1 -.156055E+01 -.100000E+03 .100000E+03 BedD2 -.704689E+00 -.100000E+03 .100000E+03 Htype .541099E+00 -.100000E+03 .100000E+03 CDum .102279E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD rent2.sgi cat >rent2b.sgi <<'//GO.SYSIN DD rent2b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 3 VARIABLE BLOCK-SIZE OPTION CHOSEN BLOCK-SIZES: 216 162 189 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .84E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .35E-03 .41E-03 .2E-01 G .0E+00 .8E-01 3 4 .415E+03 .15E-04 .15E-04 .3E-02 S .0E+00 .1E-01 4 5 .415E+03 .14E-06 .15E-06 .3E-03 S .0E+00 .1E-02 5 6 .415E+03 .22E-08 .22E-08 .3E-04 S .0E+00 .2E-03 6 7 .415E+03 .40E-10 .41E-10 .5E-05 S .0E+00 .2E-04 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .414996E+03 RELDX .468E-05 FUNC. EVALS 7 GRAD. EVALS 7 PRELDF .405E-10 NPRELDF .405E-10 I FINAL X(I) D(I) G(I) 1 -.417176E-02 .100E+01 .690E-02 2 .309495E-02 .100E+01 .151E-03 3 -.415382E+00 .100E+01 -.615E-04 4 .805209E+00 .100E+01 .614E-05 5 .739921E+00 .100E+01 .104E-03 6 -.156055E+01 .100E+01 .933E-04 7 -.704689E+00 .100E+01 -.197E-03 8 .541099E+00 .100E+01 -.279E-03 9 .102279E+01 .100E+01 .238E-03 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.414996E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415834E+03 1 - L(EST)/L(0): = .333782E+00 1 - (L(EST)-NPAR)/L(0) = .319334E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301438E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.417176E-02 -.100000E+03 .100000E+03 LocD1 .309495E-02 -.100000E+03 .100000E+03 LocD2 -.415382E+00 -.100000E+03 .100000E+03 ConD1 .805209E+00 -.100000E+03 .100000E+03 ConD2 .739921E+00 -.100000E+03 .100000E+03 BedD1 -.156055E+01 -.100000E+03 .100000E+03 BedD2 -.704689E+00 -.100000E+03 .100000E+03 Htype .541099E+00 -.100000E+03 .100000E+03 CDum .102279E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD rent2b.sgi cat >smadsen.sgi <<'//GO.SYSIN DD smadsen.sgi' GLG ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .443E+01 .88E+00 .95E+00 .2E+00 G .0E+00 .6E+01 3 6 .128E+01 .71E+00 .67E+00 .3E+00 G-S .0E+00 .5E+01 4 7 .593E+00 .54E+00 .59E+00 .1E+01 S .0E+00 .3E+01 5 8 .415E+00 .30E+00 .24E+00 .1E+00 S .0E+00 .5E+00 6 9 .390E+00 .60E-01 .87E-01 .7E-01 G .0E+00 .3E+00 7 10 .387E+00 .89E-02 .89E-02 .4E-01 S .0E+00 .1E+00 8 11 .387E+00 .24E-04 .23E-04 .2E-02 S .0E+00 .5E-02 9 12 .387E+00 .00E+00 .32E-07 .8E-04 G .0E+00 .2E-03 ***** X- AND RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .386600E+00 RELDX .815E-04 FUNC. EVALS 12 GRAD. EVALS 9 PRELDF .317E-07 NPRELDF .317E-07 I FINAL X(I) D(I) G(I) 1 -.155462E+00 .138E+01 .511E-04 2 .694676E+00 .149E+01 .218E-03 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .64 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .649 ROW 2 -.264 .575 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .733 .565E-01 .119 GLG NEEDED LIV .GE. ,I3,12H AND LV .GE. 92 GLG NEEDED LIV .GE. ,I3,12H AND LV .GE. 173 GLF ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .442E+01 .88E+00 .95E+00 .2E+00 G .0E+00 .6E+01 3 6 .128E+01 .71E+00 .67E+00 .3E+00 G-S .0E+00 .5E+01 4 7 .587E+00 .54E+00 .59E+00 .1E+01 S .0E+00 .3E+01 5 8 .415E+00 .29E+00 .24E+00 .1E+00 S .0E+00 .5E+00 6 9 .390E+00 .59E-01 .86E-01 .7E-01 G .0E+00 .3E+00 7 10 .387E+00 .90E-02 .89E-02 .4E-01 S .0E+00 .1E+00 8 11 .387E+00 .24E-04 .21E-04 .2E-02 S .0E+00 .4E-02 9 12 .387E+00 .15E-06 .30E-07 .8E-04 G .0E+00 .2E-03 10 13 .387E+00 .00E+00 .87E-07 .1E-03 G .0E+00 .3E-03 ***** X- AND RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .386600E+00 RELDX .111E-03 FUNC. EVALS 13 GRAD. EVALS 22 PRELDF .873E-07 NPRELDF .873E-07 I FINAL X(I) D(I) G(I) 1 -.155494E+00 .126E+01 .192E-03 2 .694709E+00 .146E+01 .340E-03 6 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .64 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .647 ROW 2 -.261 .572 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .723 .557E-01 .118 GLF ON PROBLEM MADSEN AGAIN... NONDEFAULT VALUES.... LMAX0..... V(35) = .1000000E+00 I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 6 .521E+02 .38E+00 .41E+00 .4E-01 G .6E+01 .2E+01 2 7 .785E+01 .85E+00 .95E+00 .1E+00 G .3E+00 .6E+01 3 9 .217E+01 .72E+00 .78E+00 .5E+00 G-S .0E+00 .9E+01 4 10 .100E+01 .54E+00 .96E+00 .5E+00 G .0E+00 .4E+01 5 11 .423E+00 .58E+00 .65E+00 .2E+00 G .0E+00 .2E+01 6 12 .392E+00 .73E-01 .12E+00 .9E-01 G .0E+00 .4E+00 7 13 .387E+00 .14E-01 .14E-01 .5E-01 S .0E+00 .1E+00 8 14 .387E+00 .33E-03 .29E-03 .7E-02 S .0E+00 .2E-01 9 15 .387E+00 .79E-05 .92E-05 .1E-02 G .0E+00 .3E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .386600E+00 RELDX .139E-02 FUNC. EVALS 15 GRAD. EVALS 20 PRELDF .915E-05 NPRELDF .915E-05 I FINAL X(I) D(I) G(I) 1 -.155806E+00 .108E+01 -.822E-03 2 .694499E+00 .139E+01 -.434E-03 //GO.SYSIN DD smadsen.sgi cat >smadsenb.sgi <<'//GO.SYSIN DD smadsenb.sgi' GLGB ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .579E+01 .84E+00 .10E+01 .2E+00 G .2E+01 .5E+01 3 5 .177E+01 .70E+00 .57E+00 .2E+00 S .0E+00 .3E+01 4 6 .660E+00 .63E+00 .59E+00 .4E+00 G .0E+00 .2E+01 5 7 .509E+00 .23E+00 .21E+00 .6E+00 G .0E+00 .7E+00 6 8 .500E+00 .17E-01 .17E-01 .9E+00 G .0E+00 .1E+00 7 9 .500E+00 .13E-04 .13E-04 .1E+01 S .0E+00 .4E-02 8 10 .500E+00 .00E+00 .50E-12 .1E+01 S .0E+00 .7E-06 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .500000E+00 RELDX .100E+01 FUNC. EVALS 10 GRAD. EVALS 8 PRELDF .496E-12 NPRELDF .496E-12 I FINAL X(I) D(I) G(I) 1 -.704546E-06 .100E+01 -.705E-06 2 .000000E+00 .314E+00 -.360E-18 GLGB NEEDED LIV .GE. ,I3,12H AND LV .GE. 92 GLGB NEEDED LIV .GE. ,I3,12H AND LV .GE. 179 GLFB ON PROBLEM MADSEN... I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 3 .365E+02 .57E+00 .62E+00 .7E-01 G .3E+01 .4E+01 2 4 .579E+01 .84E+00 .10E+01 .2E+00 G .2E+01 .5E+01 3 5 .177E+01 .70E+00 .57E+00 .2E+00 S .0E+00 .3E+01 4 6 .660E+00 .63E+00 .59E+00 .4E+00 G .0E+00 .2E+01 5 7 .509E+00 .23E+00 .21E+00 .6E+00 G .0E+00 .7E+00 6 8 .500E+00 .17E-01 .17E-01 .9E+00 G .0E+00 .1E+00 7 9 .410E+00 .18E+00 .16E-03 .1E+01 S .0E+00 .4E+00 8 10 .389E+00 .51E-01 .55E-01 .6E-01 S .0E+00 .1E+00 9 11 .389E+00 .26E-03 .26E-03 .7E-02 S .0E+00 .1E-01 10 12 .389E+00 .23E-06 .32E-06 .3E-03 S .0E+00 .5E-03 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .388964E+00 RELDX .257E-03 FUNC. EVALS 12 GRAD. EVALS 22 PRELDF .316E-06 NPRELDF .316E-06 I FINAL X(I) D(I) G(I) 1 -.100000E+00 .141E+01 .853E-01 2 .670350E+00 .144E+01 -.134E-04 GLFB ON PROBLEM MADSEN AGAIN... NONDEFAULT VALUES.... LMAX0..... V(35) = .1000000E+00 I INITIAL X(I) D(I) 1 .300000E+01 .707E+01 2 .100000E+01 .507E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .847E+02 1 6 .521E+02 .38E+00 .41E+00 .4E-01 G .6E+01 .2E+01 2 7 .753E+01 .86E+00 .10E+01 .2E+00 G .4E+00 .6E+01 3 8 .131E+01 .83E+00 .83E+00 .3E+00 G .0E+00 .5E+01 4 9 .597E+00 .54E+00 .51E+00 .4E+00 G .0E+00 .2E+01 5 10 .503E+00 .16E+00 .14E+00 .7E+00 G .0E+00 .6E+00 6 11 .500E+00 .64E-02 .64E-02 .1E+01 G .0E+00 .9E-01 7 13 .481E+00 .38E-01 .96E-04 .1E+01 S .3E-02 .1E+00 8 15 .404E+00 .16E+00 .26E+00 .5E+00 S .4E+01 .2E+00 9 16 .389E+00 .36E-01 .39E-01 .6E-01 G .0E+00 .1E+00 10 17 .389E+00 .22E-03 .24E-03 .7E-02 G .0E+00 .1E-01 11 18 .389E+00 .25E-05 .25E-05 .7E-03 G .0E+00 .1E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .388964E+00 RELDX .742E-03 FUNC. EVALS 18 GRAD. EVALS 25 PRELDF .246E-05 NPRELDF .246E-05 I FINAL X(I) D(I) G(I) 1 -.100000E+00 .140E+01 .852E-01 2 .670314E+00 .145E+01 -.141E-03 //GO.SYSIN DD smadsenb.sgi cat >smnpex1.sgi <<'//GO.SYSIN DD smnpex1.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 5 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .546E+02 1 2 .390E+02 .29E+00 .24E+00 .4E+00 G .1E+00 .1E+01 2 3 .345E+02 .11E+00 .13E+00 .5E+00 G .2E+01 .1E+01 3 4 .335E+02 .30E-01 .53E-01 .3E+00 G .0E+00 .6E+00 4 5 .325E+02 .30E-01 .27E-01 .2E+00 S .0E+00 .2E+00 5 6 .323E+02 .59E-02 .69E-02 .1E+00 S .0E+00 .2E+00 6 7 .323E+02 .10E-02 .97E-03 .2E-01 S .0E+00 .3E-01 7 8 .323E+02 .11E-03 .99E-04 .8E-02 S .0E+00 .1E-01 8 9 .323E+02 .84E-05 .25E-04 .7E-02 S .0E+00 .1E-01 9 10 .323E+02 .19E-05 .27E-05 .3E-02 S .0E+00 .4E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .322698E+02 RELDX .252E-02 FUNC. EVALS 10 GRAD. EVALS 10 PRELDF .274E-05 NPRELDF .274E-05 I FINAL X(I) D(I) G(I) 1 -.112553E+00 .100E+01 -.124E-02 2 .143818E-01 .100E+01 -.111E-01 3 .200048E+00 .100E+01 -.785E-03 4 .592161E+00 .100E+01 .106E-02 5 .310121E+00 .100E+01 -.122E-01 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .48E-01 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .209E-02 ROW 2 .515E-02 .147 ROW 3 .644E-02 .113 .994E-01 ROW 4 -.242E-02 .544E-01 .381E-01 .460E-01 ROW 5 -.131E-01 -.104E-01 -.276E-01 .286E-01 .121 REGRESSION DIAGNOSTIC VECTOR NOT COMPUTED ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 TTIME -.112553E+00 -.246423E+01 .456747E-01 2 DBUS .143818E-01 .375494E-01 .383010E+00 3 DSTREETC .200048E+00 .634497E+00 .315286E+00 4 B21 .592161E+00 .276175E+01 .214415E+00 5 B22 .310121E+00 .889841E+00 .348513E+00 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.322698E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .453217E+02 1 - L(EST)/L(0): = .412536E+00 1 - (L(EST)-NPAR)/L(0) = .321512E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .302233E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.112553E+00 -.100000E+03 .100000E+03 DBUS .143818E-01 -.100000E+03 .100000E+03 DSTREETC .200048E+00 -.100000E+03 .100000E+03 B21 .592161E+00 -.100000E+03 .100000E+03 B22 .310121E+00 -.100000E+03 .100000E+03 //GO.SYSIN DD smnpex1.sgi cat >smnpex1b.sgi <<'//GO.SYSIN DD smnpex1b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 5 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .546E+02 1 2 .390E+02 .29E+00 .24E+00 .4E+00 G .1E+00 .1E+01 2 3 .345E+02 .11E+00 .13E+00 .5E+00 G .2E+01 .1E+01 3 4 .335E+02 .30E-01 .53E-01 .3E+00 G .0E+00 .6E+00 4 5 .325E+02 .30E-01 .27E-01 .2E+00 S .0E+00 .2E+00 5 6 .323E+02 .59E-02 .68E-02 .1E+00 S .0E+00 .2E+00 6 7 .323E+02 .10E-02 .97E-03 .2E-01 S .0E+00 .3E-01 7 8 .323E+02 .10E-03 .10E-03 .9E-02 S .0E+00 .2E-01 8 9 .323E+02 .15E-04 .24E-04 .5E-02 S .0E+00 .9E-02 9 10 .323E+02 -.35E-06 .15E-05 .2E-02 S .0E+00 .3E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .322697E+02 RELDX .175E-02 FUNC. EVALS 10 GRAD. EVALS 9 PRELDF .147E-05 NPRELDF .147E-05 I FINAL X(I) D(I) G(I) 1 -.112841E+00 .100E+01 -.169E+00 2 .124978E-01 .100E+01 .739E-02 3 .198375E+00 .100E+01 -.135E-02 4 .590946E+00 .100E+01 -.574E-01 5 .311070E+00 .100E+01 -.998E-02 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.322697E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .453218E+02 1 - L(EST)/L(0): = .412537E+00 1 - (L(EST)-NPAR)/L(0) = .321513E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .302233E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.112841E+00 -.100000E+03 .100000E+03 DBUS .124978E-01 -.100000E+03 .100000E+03 DSTREETC .198375E+00 -.100000E+03 .100000E+03 B21 .590946E+00 -.100000E+03 .100000E+03 B22 .311070E+00 -.100000E+03 .100000E+03 //GO.SYSIN DD smnpex1b.sgi cat >smnpex2.sgi <<'//GO.SYSIN DD smnpex2.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS UNCORRELATED RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 6 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 6 SigT .100000E+01 .100000E-03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 6 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .535E+02 1 2 .346E+02 .35E+00 .30E+00 .4E+00 G .6E+01 .1E+01 2 4 .326E+02 .57E-01 .52E-01 .9E-01 G .7E+01 .4E+00 3 5 .323E+02 .94E-02 .14E-01 .1E+00 G .7E+00 .4E+00 4 6 .322E+02 .44E-02 .91E-02 .1E+00 G .4E+00 .4E+00 5 7 .321E+02 .20E-02 .27E-02 .1E+00 S .1E+00 .4E+00 6 8 .321E+02 .12E-02 .12E-02 .1E+00 S .0E+00 .4E+00 7 9 .320E+02 .12E-02 .70E-03 .8E-01 S .0E+00 .2E+00 8 10 .320E+02 .79E-03 .48E-03 .9E-01 G .0E+00 .2E+00 9 11 .320E+02 .31E-03 .39E-03 .1E+00 S .0E+00 .2E+00 10 12 .320E+02 .68E-04 .79E-04 .2E-01 S .0E+00 .3E-01 11 13 .320E+02 .59E-05 .50E-05 .6E-02 S .0E+00 .1E-01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .319875E+02 RELDX .596E-02 FUNC. EVALS 13 GRAD. EVALS 12 PRELDF .497E-05 NPRELDF .497E-05 I FINAL X(I) D(I) G(I) 1 -.233637E+00 .100E+01 -.360E-02 2 -.225658E+00 .100E+01 .931E-02 3 .121536E-02 .100E+01 -.653E-02 4 .367811E+00 .100E+01 -.709E-02 5 .607494E+00 .100E+01 .944E-03 6 .120730E+00 .100E+01 .183E-03 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .26E-01 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .347E-01 ROW 2 .526E-01 .376 ROW 3 .505E-01 .289 .263 ROW 4 .831E-01 .400 .336 .579 ROW 5 -.916E-01 -.700E-01 -.941E-01 -.162 .371 ROW 6 -.238E-01 -.333E-01 -.312E-01 -.564E-01 .617E-01 .177E-01 REGRESSION DIAGNOSTIC VECTOR NOT COMPUTED ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 TTIME -.233637E+00 -.125475E+01 .186202E+00 2 DBUS -.225658E+00 -.367971E+00 .613250E+00 3 DSTREETC .121536E-02 .237165E-02 .512456E+00 4 B21 .367811E+00 .483344E+00 .760971E+00 5 B22 .607494E+00 .996742E+00 .609480E+00 6 SigT .120730E+00 .906854E+00 .133131E+00 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.319875E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .458862E+02 1 - L(EST)/L(0): = .417674E+00 1 - (L(EST)-NPAR)/L(0) = .308445E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .307877E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.233637E+00 -.100000E+03 .100000E+03 DBUS -.225658E+00 -.100000E+03 .100000E+03 DSTREETC .121536E-02 -.100000E+03 .100000E+03 B21 .367811E+00 -.100000E+03 .100000E+03 B22 .607494E+00 -.100000E+03 .100000E+03 SigT .120730E+00 .100000E-03 .100000E+03 //GO.SYSIN DD smnpex2.sgi cat >smnpex2b.sgi <<'//GO.SYSIN DD smnpex2b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 50 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 3 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN NO REGRESSION DIAGNOSTICS REQUESTED *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 1 NOMINAL DUMMIES USED CORRELATED ERROR TERMS UNCORRELATED RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 6 INITIAL PARAMETER VECTOR AND BOUNDS: 1 TTIME .000000E+00 -.100000E+03 .100000E+03 2 DBUS .000000E+00 -.100000E+03 .100000E+03 3 DSTREETC .000000E+00 -.100000E+03 .100000E+03 4 B21 .100000E+01 -.100000E+03 .100000E+03 5 B22 .100000E+01 -.100000E+03 .100000E+03 6 SigT .100000E+01 .100000E-03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .100000E+01 .100E+01 5 .100000E+01 .100E+01 6 .100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .535E+02 1 2 .346E+02 .35E+00 .30E+00 .4E+00 G .6E+01 .1E+01 2 4 .326E+02 .57E-01 .52E-01 .9E-01 G .7E+01 .4E+00 3 5 .323E+02 .94E-02 .14E-01 .1E+00 G .7E+00 .4E+00 4 6 .322E+02 .44E-02 .91E-02 .1E+00 G .4E+00 .4E+00 5 7 .321E+02 .19E-02 .27E-02 .1E+00 S .1E+00 .4E+00 6 8 .321E+02 .11E-02 .11E-02 .1E+00 S .0E+00 .4E+00 7 9 .320E+02 .12E-02 .67E-03 .8E-01 S .0E+00 .2E+00 8 10 .320E+02 .76E-03 .52E-03 .1E+00 G .0E+00 .2E+00 9 11 .320E+02 .42E-03 .48E-03 .1E+00 S .0E+00 .2E+00 10 12 .320E+02 .81E-04 .74E-04 .9E-02 S .0E+00 .2E-01 11 13 .320E+02 .23E-05 .91E-05 .9E-02 S .0E+00 .1E-01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .319876E+02 RELDX .902E-02 FUNC. EVALS 13 GRAD. EVALS 12 PRELDF .909E-05 NPRELDF .909E-05 I FINAL X(I) D(I) G(I) 1 -.233447E+00 .100E+01 .767E-01 2 -.224785E+00 .100E+01 .123E-01 3 .171215E-02 .100E+01 -.284E-01 4 .369596E+00 .100E+01 .205E-02 5 .608068E+00 .100E+01 .125E-01 6 .120652E+00 .100E+01 .661E-01 NUMBER OF OBSERVATIONS (NOBS) = 50 LOG-LIKELIHOOD L(EST) = -.319876E+02 LOG-LIKELIHOOD L(0) = -.549306E+02 -2[L(0) - L(EST)]: = .458861E+02 1 - L(EST)/L(0): = .417674E+00 1 - (L(EST)-NPAR)/L(0) = .308445E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 14.000 .2800 2 29.000 .5800 3 7.000 .1400 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.473814E+02 -2[L(C) - L(EST)]: = .307877E+02 OUTPUT FOR CONVENIENT RESTART: TTIME -.233447E+00 -.100000E+03 .100000E+03 DBUS -.224785E+00 -.100000E+03 .100000E+03 DSTREETC .171215E-02 -.100000E+03 .100000E+03 B21 .369596E+00 -.100000E+03 .100000E+03 B22 .608068E+00 -.100000E+03 .100000E+03 SigT .120652E+00 .100000E-03 .100000E+03 //GO.SYSIN DD smnpex2b.sgi cat >spmain.sgi <<'//GO.SYSIN DD spmain.sgi' * 28 **** problem e1 **** * 10 Example Frome '84 pp. 8-10 (Table 2, In-Vitro Dose Response, 192 Ir ra * 7 Run 1: calling GLG with PS = 2 I INITIAL X(I) D(I) 1 .499434E-01 .963E+02 2 .578438E-01 .259E+03 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .486E+03 1 2 .486E+03 .49E-03 .49E-03 .2E-01 G .2E+00 .9E+00 2 3 .486E+03 .13E-03 .14E-03 .2E-01 G .0E+00 .9E+00 3 4 .486E+03 .25E-06 .25E-06 .8E-03 G .0E+00 .3E-01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .486108E+03 RELDX .810E-03 FUNC. EVALS 4 GRAD. EVALS 4 PRELDF .251E-06 NPRELDF .251E-06 I FINAL X(I) D(I) G(I) 1 .359301E-01 .102E+03 -.275E-02 2 .621813E-01 .259E+03 -.212E-02 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .20 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .304E-03 ROW 2 -.990E-04 .472E-04 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .678E-01 .122E-01 .678E-01 .312E-02 .122E-01 .580E-01 .312E-02 .839E-04 .117E-01 .839E-04 .746E-02 .100 .183E-05 .203E-02 .844E-02 .147 .109E-01 .209E-01 .215E-02 .966E-01 DEVIANCE = 12.6692095 * 28 **** problem e2.2 **** * 10 Data for model (2.2) in Frome '84. * 7 Run 2: calling GLG with PS = 3 I INITIAL X(I) D(I) 1 .353129E+01 .520E+01 2 .359229E+01 .122E+02 3 .227781E+01 .724E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.865E+04 1 3 -.865E+04 .17E-03 .17E-03 .2E-01 G .5E+00 .1E+01 2 4 -.865E+04 .11E-03 .11E-03 .3E-01 G .0E+00 .3E+01 3 5 -.865E+04 .23E-06 .11E-06 .6E-03 G .0E+00 .5E-01 4 6 -.865E+04 .00E+00 .17E-12 .8E-06 G .0E+00 .8E-04 ***** X- AND RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.865021E+04 RELDX .790E-06 FUNC. EVALS 6 GRAD. EVALS 4 PRELDF .173E-12 NPRELDF .173E-12 I FINAL X(I) D(I) G(I) 1 .285931E+01 .544E+01 -.274E-03 2 .379916E+01 .121E+02 -.372E-03 3 .225735E+01 .713E+01 .145E-03 4 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 4 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .25 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .944E-01 ROW 2 -.344E-01 .200E-01 ROW 3 -.271E-02 .456E-02 .215E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .304E-01 .122E-02 .195 .178E-01 .831E-01 .482E-01 .131 .394E-01 .477E-01 .202E-01 .434E-01 .174E-01 .294E-02 .358E-01 .506E-01 .269E-01 .108E-02 .348E-01 1.39 .835E-01 .577E-02 .185 .412E-02 .108E-01 .236E-01 .224 .370E-04 DEVIANCE = 29.9574928 * 28 **** problem e2.6 **** * 10 Data for model (2.6) in Frome '84. * 7 Run 3: calling GLG with PS = 3 I INITIAL X(I) D(I) 1 .800000E+01 .713E+01 2 .100000E+01 .220E+02 3 .310000E+01 .362E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.796E+04 1 4 -.820E+04 .30E-01 .30E-01 .2E-01 G .1E+02 .4E+01 2 5 -.860E+04 .47E-01 .57E-01 .1E+00 G .1E+01 .1E+02 3 6 -.863E+04 .27E-02 .40E-02 .1E+00 S .0E+00 .2E+02 4 7 -.865E+04 .27E-02 .34E-02 .6E-01 S .0E+00 .1E+02 5 8 -.865E+04 .23E-03 .18E-03 .2E-01 S .0E+00 .2E+01 6 9 -.865E+04 .19E-04 .17E-04 .6E-02 G .0E+00 .1E+01 7 10 -.865E+04 .45E-06 .58E-06 .1E-02 S .0E+00 .1E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.865104E+04 RELDX .116E-02 FUNC. EVALS 10 GRAD. EVALS 8 PRELDF .579E-06 NPRELDF .579E-06 I FINAL X(I) D(I) G(I) 1 .542779E+01 .108E+02 -.395E-01 2 .271442E+00 .305E+02 -.138E+00 3 .740348E+01 .155E+01 -.582E-02 4 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 4 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .36E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .435E-01 ROW 2 -.113E-01 .471E-02 ROW 3 -.735E-01 -.194E-02 .824 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .486E-03 .145 .977E-02 .183E-01 .466E-01 .845E-03 .128E-01 .275E-02 .295E-01 .103 .219E-02 .747E-02 .582E-02 .176E-01 .464E-01 .359E-01 .684E-03 .886E-01 1.62 .383 .126 .397 .553E-03 .102E-02 .273E-01 .139 .428E-01 DEVIANCE = 28.3012428 * 28 **** problem e2.8 **** * 10 Data for model (2.8) in Frome '84. * 7 Run 4: calling GLG with PS = 4 I INITIAL X(I) D(I) 1 .300000E+01 .517E+01 2 .200000E+01 .290E+02 3 .100000E+01 .916E+02 4 .300000E+01 .107E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .113E+09 1 3 .105E+09 .72E-01 .74E-01 .6E-02 G .3E+07 .2E+01 2 5 .361E+08 .66E+00 .11E+01 .9E-01 G .2E+06 .2E+02 3 6 .307E+08 .15E+00 .56E+00 .1E+00 S .3E+00 .7E+04 4 8 .178E+08 .42E+00 .32E+00 .4E-01 S .6E+00 .2E+04 5 9 .104E+08 .42E+00 .37E+00 .8E-01 S .4E+00 .3E+04 6 10 .476E+07 .54E+00 .57E+00 .1E+00 S .4E+00 .3E+04 7 11 .262E+07 .45E+00 .31E+00 .3E+00 S .2E-01 .3E+04 8 12 .125E+07 .52E+00 .39E+00 .4E+00 S .6E-02 .3E+04 9 13 .600E+06 .52E+00 .42E+00 .6E+00 S .1E-01 .3E+04 10 14 .295E+06 .51E+00 .37E+00 .4E+00 S .0E+00 .1E+04 11 15 .142E+06 .52E+00 .39E+00 .4E+00 S .0E+00 .2E+04 12 16 .729E+05 .49E+00 .34E+00 .7E-01 S .0E+00 .4E+03 13 17 .390E+05 .47E+00 .32E+00 .1E+00 S .0E+00 .4E+03 14 18 .223E+05 .43E+00 .30E+00 .8E-01 S .0E+00 .2E+03 15 19 .144E+05 .36E+00 .25E+00 .7E-01 S .0E+00 .2E+03 16 20 .108E+05 .25E+00 .18E+00 .6E-01 S .0E+00 .1E+03 17 21 .930E+04 .14E+00 .10E+00 .5E-01 S .0E+00 .8E+02 18 22 .882E+04 .51E-01 .40E-01 .4E-01 S .0E+00 .5E+02 19 23 .872E+04 .12E-01 .99E-02 .4E-01 S .0E+00 .4E+02 20 24 .870E+04 .22E-02 .19E-02 .3E-01 S .0E+00 .3E+02 21 25 .870E+04 .20E-03 .20E-03 .1E-01 G .0E+00 .1E+02 22 26 .870E+04 .13E-04 .15E-04 .4E-02 G .0E+00 .3E+01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .869543E+04 RELDX .420E-02 FUNC. EVALS 26 GRAD. EVALS 23 PRELDF .146E-04 NPRELDF .146E-04 I FINAL X(I) D(I) G(I) 1 .339943E+01 .608E+01 .719E+00 2 -.888441E+01 .308E+02 .305E-01 3 .824732E+00 .971E+02 -.916E+00 4 -.871153E+01 .101E+02 -.115E+00 5 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 5 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .45E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .324E-01 ROW 2 -.457E-02 .506E-01 ROW 3 .975E-03 -.157E-01 .499E-02 ROW 4 -.264E-02 -.780E-02 .214E-02 .126E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .349E-02 .777E-04 .269E-02 .283 .179 .124E-01 .534E-02 .720E-04 .273E-02 .994E-01 .454E-03 .934E-06 .192 .549E-01 .193 .216E-01 3.88 .242 .857E-05 .185 .683E-03 .873 .839 .143E-01 .218E-02 .200E-02 .250E-02 .231E-01 .220E-01 .772E-03 DEVIANCE = 43.5261726 * 28 **** problem e3.1 **** * 10 Data for model (3.1) in Frome '84. * 7 Run 5: calling GLG with PS = 2 I INITIAL X(I) D(I) 1 .317713E-01 .157E+03 2 .467588E-02 .550E+04 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .109E+04 1 2 .109E+04 .25E-03 .27E-03 .1E-01 G .1E+00 .9E+00 2 3 .109E+04 .18E-05 .18E-05 .1E-02 G .0E+00 .8E-01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .108871E+04 RELDX .137E-02 FUNC. EVALS 3 GRAD. EVALS 3 PRELDF .176E-05 NPRELDF .176E-05 I FINAL X(I) D(I) G(I) 1 .266970E-01 .175E+03 -.342E-01 2 .477901E-02 .549E+04 -.202E+00 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .28E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .435E-04 ROW 2 -.697E-06 .443E-07 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). 9.86 .179 .326E-02 .677 .325 DEVIANCE = 6.03780556 * 28 **** problem e3.3 **** * 10 Data for model (3.3) in Frome '84. * 7 Run 6: calling GLG with PS = 2 I INITIAL X(I) D(I) 1 .317714E-01 .251E+02 2 .467588E-02 .137E+04 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .171E+04 1 3 .162E+04 .53E-01 .53E-01 .2E+00 G .9E+01 .3E+01 2 5 .128E+04 .21E+00 .20E+00 .8E+00 G .5E+00 .2E+02 3 6 .113E+04 .12E+00 .13E+00 .4E+00 S .9E-01 .3E+02 4 7 .110E+04 .19E-01 .17E-01 .1E+00 S .0E+00 .2E+02 5 8 .110E+04 .10E-02 .95E-03 .3E-01 S .0E+00 .4E+01 6 9 .110E+04 .14E-04 .14E-04 .4E-02 S .0E+00 .6E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .110260E+04 RELDX .397E-02 FUNC. EVALS 9 GRAD. EVALS 7 PRELDF .138E-04 NPRELDF .138E-04 I FINAL X(I) D(I) G(I) 1 -.276152E+01 .191E+02 .376E-01 2 .307740E-01 .123E+04 .375E+00 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .64E-02 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .162E-01 ROW 2 -.228E-03 .389E-05 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). 6.11 8.03 .800 .944 .404 DEVIANCE = 33.8224754 * 28 **** problem e3.5 **** * 10 Model (3.5), p. 25 of Frome '84 * 7 Run 7: calling GLG with PS = 9 I INITIAL X(I) D(I) 1 .249281E+00 .615E+02 2 -.809729E-01 .391E+02 3 -.683860E-01 .570E+02 4 -.619460E-01 .464E+02 5 -.507099E-01 .382E+02 6 -.167601E-01 .429E+02 7 .218034E-02 .358E+02 8 .302952E-01 .287E+02 9 .629406E-01 .288E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .150E+05 1 4 .143E+05 .49E-01 .49E-01 .1E+00 G .3E+02 .5E+01 2 6 .778E+04 .45E+00 .44E+00 .7E+00 G .9E+00 .6E+02 3 7 .495E+04 .36E+00 .32E+00 .5E+00 G .3E-01 .1E+03 4 8 .433E+04 .12E+00 .10E+00 .3E+00 G .0E+00 .8E+02 5 9 .422E+04 .26E-01 .23E-01 .2E+00 G .0E+00 .5E+02 6 10 .422E+04 .14E-02 .13E-02 .4E-01 G .0E+00 .1E+02 7 11 .422E+04 .49E-05 .49E-05 .2E-02 G .0E+00 .7E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .421723E+04 RELDX .204E-02 FUNC. EVALS 11 GRAD. EVALS 8 PRELDF .493E-05 NPRELDF .493E-05 I FINAL X(I) D(I) G(I) 1 .258354E+01 .447E+02 .105E-01 2 -.361239E+01 .146E+02 .959E-02 3 -.316187E+01 .338E+02 .275E-02 4 -.307282E+01 .277E+02 -.779E-03 5 -.297114E+01 .233E+02 .150E-02 6 -.280540E+01 .237E+02 .374E-02 7 -.265188E+01 .226E+02 .218E-02 8 -.241708E+01 .183E+02 .162E-02 9 -.220365E+01 .197E+02 .184E-02 10 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 10 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .14 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .502E-02 ROW 2 -.350E-02 .715E-02 ROW 3 -.353E-02 .246E-02 .336E-02 ROW 4 -.336E-02 .235E-02 .236E-02 .356E-02 ROW 5 -.321E-02 .224E-02 .226E-02 .215E-02 .391E-02 ROW 6 -.296E-02 .206E-02 .208E-02 .198E-02 .189E-02 .351E-02 ROW 7 -.300E-02 .209E-02 .211E-02 .201E-02 .192E-02 .177E-02 .375E-02 ROW 8 -.267E-02 .186E-02 .187E-02 .179E-02 .171E-02 .157E-02 .159E-02 .440E-02 ROW 9 -.251E-02 .175E-02 .177E-02 .168E-02 .161E-02 .148E-02 .150E-02 .133E-02 .383E-02 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .174E-06 .331E-04 .321E-01 .622E-03 .983E-02 .666E-02 .285 2.96 .177E-01 .496E-01 .184E-01 .882E-02 .354E-02 .151E-01 .546E-01 .436E-02 2.33 .118 .486E-01 .790E-01 .104E-03 .572E-02 .147E-01 .179E-01 .107 .999 .232 .135E-05 .201E-01 .483E-01 .287E-03 .839E-02 .372E-03 .131E-04 1.31 .113 .183E-03 .299E-01 .102E-01 .131E-02 .113E-02 .146E-01 .132 .309E-02 .111E-01 .162E-03 .645E-02 .243E-01 .100E-01 .194E-01 .379E-01 .105 .239 .200E-02 .291E-01 .624E-01 .383E-01 .321E-01 .660E-01 .489E-01 .631E-02 .150 .105 .165E-01 .126E-03 .116 .136 .608E-02 .279 .336E-01 6.10 .166E-01 DEVIANCE = 133.615875 * 28 **** problem ex1 **** * 10 PRLRT1.DAT: RC3- BIOMETRICS ( 1965 ) P. 613 * 7 Run 8: calling GLG with PS = 2 I INITIAL X(I) D(I) 1 .157316E+03 .347E+00 2 -.813266E+02 .144E+00 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.524E+04 1 3 -.524E+04 .29E-04 .29E-04 .1E-01 G .1E-01 .2E+01 2 4 -.524E+04 .11E-05 .12E-05 .3E-02 G .0E+00 .5E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.523742E+04 RELDX .297E-02 FUNC. EVALS 4 GRAD. EVALS 3 PRELDF .124E-05 NPRELDF .124E-05 I FINAL X(I) D(I) G(I) 1 .162106E+03 .346E+00 -.963E-04 2 -.920798E+02 .144E+00 -.306E-04 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .12 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 72.7 ROW 2 -164. 417. REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .729E-01 .251 .160E-02 .231 .466E-01 .151 .353 .109E-01 .383E-01 .226E-01 .557 DEVIANCE = 14.1978159 * 28 **** problem ex2 **** * 10 PRLLT3.DAT: NELDER-WEDDERBURN (1972) P.378 * 7 Run 9: calling GLG with PS = 9 I INITIAL X(I) D(I) 1 .502999E+00 .149E+02 2 .133298E+01 .700E+01 3 .169254E+01 .707E+01 4 .228643E+01 .768E+01 5 .203102E+01 .663E+01 6 -.184724E-01 .640E+01 7 .480533E-01 .648E+01 8 .864793E+00 .100E+02 9 -.173518E+00 .436E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.354E+03 1 2 -.355E+03 .28E-02 .27E-02 .2E-01 G .7E+00 .9E+00 2 3 -.355E+03 .11E-02 .11E-02 .4E-01 G .2E-01 .2E+01 3 4 -.355E+03 .15E-03 .14E-03 .4E-01 G .0E+00 .2E+01 4 5 -.355E+03 .40E-05 .38E-05 .4E-02 G .0E+00 .2E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.355016E+03 RELDX .356E-02 FUNC. EVALS 5 GRAD. EVALS 5 PRELDF .376E-05 NPRELDF .376E-05 I FINAL X(I) D(I) G(I) 1 .359375E+00 .149E+02 -.137E-02 2 .137204E+01 .705E+01 -.220E-01 3 .185962E+01 .707E+01 .679E-03 4 .243636E+01 .769E+01 .429E-02 5 .250562E+01 .663E+01 -.350E-02 6 .623542E-01 .651E+01 .737E-02 7 .602938E-01 .654E+01 .209E-01 8 .837021E+00 .100E+02 -.437E-01 9 -.204820E+00 .438E+02 .790E-01 10 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 10 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .28E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .142 ROW 2 -.886E-01 .910E-01 ROW 3 -.122 .892E-01 .143 ROW 4 -.148 .104 .150 .203 ROW 5 -.168 .115 .170 .214 .270 ROW 6 -.312E-01 .281E-02 .522E-02 .736E-02 .932E-02 .504E-01 ROW 7 -.293E-01 .163E-02 .280E-02 .390E-02 .506E-02 .264E-01 .508E-01 ROW 8 -.194E-01 -.353E-02 -.690E-02 -.978E-02 -.121E-01 .258E-01 .267E-01 .377E-01 ROW 9 .142E-01 -.755E-02 -.137E-01 -.184E-01 -.222E-01 -.150E-02 -.146E-02 .795E-04 .251E-02 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .233E-01 .260 .215E-01 1.60 .358E-02 .876E-03 4.60 1.63 .199 .923E-01 .278E-01 .270 1.06 .480 .259 .644 .201E-01 .109 .359 71.2 DEVIANCE = 14.0764456 * 28 **** problem ex3 **** * 10 PRNLT1.DAT: TILL AND MCCUL. (1961) DATA-- TARGET MODEL * 7 Run 10: calling GLG with PS = 3 I INITIAL X(I) D(I) 1 .800000E+01 .264E+01 2 .100000E+01 .764E+02 3 .310000E+01 .550E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 -.584E+03 1 3 -.590E+03 .90E-02 .93E-02 .1E-01 G .5E+00 .2E+01 2 4 -.591E+03 .16E-02 .16E-02 .2E-01 G .0E+00 .4E+01 3 5 -.591E+03 .10E-04 .99E-05 .3E-03 G .0E+00 .7E-01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION -.590639E+03 RELDX .267E-03 FUNC. EVALS 5 GRAD. EVALS 4 PRELDF .993E-05 NPRELDF .993E-05 I FINAL X(I) D(I) G(I) 1 .763720E+01 .291E+01 .405E-03 2 .934066E+00 .851E+02 -.107E-01 3 .289151E+01 .635E+01 -.510E-03 4 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 4 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .10E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .872 ROW 2 -.147E-01 .171E-02 ROW 3 -.555 .279E-01 .615 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). 2.69 .307 .386 .787 .396E-01 1.87 .581 DEVIANCE = 8.01756573 * 28 **** problem ex8-10 **** * 10 Example Frome '84 pp. 8-10 (Table 2, In-Vitro Dose Response, 192 Ir r * 7 Run 11: calling GLG with PS = 2 I INITIAL X(I) D(I) 1 .499434E-01 .963E+02 2 .578438E-01 .259E+03 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .486E+03 1 2 .486E+03 .49E-03 .49E-03 .2E-01 G .2E+00 .9E+00 2 3 .486E+03 .13E-03 .14E-03 .2E-01 G .0E+00 .9E+00 3 4 .486E+03 .19E-06 .25E-06 .8E-03 G .0E+00 .3E-01 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .486108E+03 RELDX .810E-03 FUNC. EVALS 4 GRAD. EVALS 4 PRELDF .251E-06 NPRELDF .251E-06 I FINAL X(I) D(I) G(I) 1 .359301E-01 .102E+03 -.282E-02 2 .621813E-01 .259E+03 -.225E-02 3 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 3 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .20 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .304E-03 ROW 2 -.991E-04 .472E-04 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .563 .313 .245E-01 4.12 DEVIANCE = 1.38060534 * 28 **** problem mn202 **** * 10 Example on p. 202 of McCullagh and Nelder * 7 Run 12: calling GLG with PS = 7 I INITIAL X(I) D(I) 1 .100000E+01 .729E+01 2 .100000E+01 .952E-01 3 .400000E+02 .226E-02 4 .200000E+01 .191E+00 5 .220000E+02 .151E-01 6 .300000E+01 .125E+00 7 .320000E+02 .104E-01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .310E+03 1 2 .272E+03 .12E+00 .17E+00 .4E-01 G .6E+02 .9E+00 2 4 .230E+03 .15E+00 .14E+00 .3E-01 G .8E+01 .9E+00 3 8 .188E+03 .18E+00 .20E+00 .1E+00 G .4E+01 .3E+01 4 10 .180E+03 .47E-01 .66E-01 .6E-01 G .1E+00 .9E+01 5 13 .177E+03 .11E-01 .14E-01 .2E-01 G .2E-01 .1E+02 6 14 .176E+03 .10E-01 .13E-01 .2E-01 G .2E-01 .1E+02 7 15 .172E+03 .19E-01 .19E+01 .2E-01 S .5E+01 .1E+02 8 18 .166E+03 .37E-01 .54E-01 .1E+00 S .7E-02 .3E+02 9 19 .159E+03 .45E-01 .33E-01 .3E+00 S .2E-02 .3E+02 10 20 .158E+03 .36E-02 .25E-01 .2E+00 S -.1E-01 .2E+02 11 24 .157E+03 .75E-02 .79E-02 .1E+00 G-S-G .3E-02 .9E+01 12 25 .157E+03 .13E-02 .25E-02 .2E+00 G .6E-04 .9E+01 13 28 .156E+03 .14E-02 .15E-02 .8E-01 G .3E-02 .1E+01 14 29 .156E+03 .86E-04 .87E-04 .1E+00 G .2E-02 .1E+01 15 31 .156E+03 .18E-04 .18E-04 .1E-01 G .2E-01 .2E+00 16 34 .156E+03 .69E-05 .66E-05 .3E-01 G .0E+00 .3E+00 ***** SINGULAR CONVERGENCE ***** FUNCTION .156437E+03 RELDX .254E-01 FUNC. EVALS 34 GRAD. EVALS 17 PRELDF .660E-05 NPRELDF .163E-04 I FINAL X(I) D(I) G(I) 1 .873500E-01 .385E+02 -.317E+00 2 .132476E+02 .262E+00 -.132E-02 3 .448838E+02 .625E-01 .166E-03 4 .128568E+01 .856E+00 -.447E-02 5 .256497E+02 .350E-01 .316E-03 6 .193911E+01 .489E+00 -.254E-02 7 .438249E+02 .181E-01 .116E-03 DEVIANCE = 2.00754181E-01 * 28 **** problem mn202.1 **** * 10 Example on p. 202 of McCullagh and Nelder * 7 Run 13: calling GLG with PS = 7 I INITIAL X(I) D(I) 1 .100000E+01 .535E+01 2 .200000E+01 .641E+00 3 .300000E+01 .427E+00 4 .400000E+01 .394E+00 5 .500000E+01 .300E+00 6 .600000E+01 .268E+00 7 .700000E+01 .223E+00 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .429E+03 1 3 .217E+03 .50E+00 .70E+00 .2E+00 G .2E+02 .4E+01 2 6 .181E+03 .16E+00 .17E+00 .1E+00 G .1E+02 .2E+01 3 7 .168E+03 .75E-01 .17E+00 .5E+00 G .4E+00 .7E+01 4 9 .163E+03 .25E-01 .23E-01 .1E+00 G .5E-03 .1E+02 5 10 .158E+03 .31E-01 .15E-01 .2E+00 G .5E-03 .1E+02 6 13 .157E+03 .93E-02 .83E-02 .2E+00 G .3E-02 .4E+01 7 15 .157E+03 .17E-02 .16E-02 .3E-01 G .4E+00 .5E+00 8 16 .156E+03 .52E-03 .51E-03 .4E-01 G .2E-01 .9E+00 9 17 .156E+03 .65E-04 .67E-04 .6E-01 G .9E-02 .8E+00 10 19 .156E+03 .38E-04 .42E-04 .6E-01 G .4E-02 .1E+01 11 20 .156E+03 .25E-04 .49E-04 .1E+00 G .1E-02 .2E+01 12 21 .156E+03 .21E-04 .34E-04 .9E-01 G .0E+00 .1E+01 13 22 .156E+03 .14E-04 .14E-04 .2E-01 G .0E+00 .2E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .156435E+03 RELDX .159E-01 FUNC. EVALS 22 GRAD. EVALS 14 PRELDF .142E-04 NPRELDF .142E-04 I FINAL X(I) D(I) G(I) 1 .976380E-01 .381E+02 -.160E+00 2 .131584E+02 .262E+00 -.806E-03 3 .446218E+02 .626E-01 .101E-03 4 .680890E+00 .127E+01 -.590E-02 5 .152562E+02 .500E-01 .201E-03 6 .134709E+01 .610E+00 -.307E-02 7 .327679E+02 .219E-01 .103E-03 7 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 7 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. ++++++ INDEFINITE COVARIANCE MATRIX ++++++ DEVIANCE = 1.97000518E-01 * 28 **** problem mn204 **** * 10 Example on p. 205 of McCullagh and Nelder * 7 Run 14: calling GLG with PS = 4 I INITIAL X(I) D(I) 1 .100000E+01 .937E+01 2 .100000E+01 .176E+02 3 .100000E+01 .513E+01 4 .100000E+01 .582E+00 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .397E+04 1 5 .188E+04 .53E+00 .65E+00 .3E+00 G .1E+02 .1E+02 2 6 .150E+04 .20E+00 .23E+00 .7E+00 G .1E+00 .3E+02 3 8 .141E+04 .55E-01 .55E-01 .3E+00 G .1E-01 .4E+02 4 9 .136E+04 .39E-01 .36E-01 .3E+00 G .0E+00 .6E+02 5 10 .136E+04 .12E-02 .12E-02 .4E-01 G .0E+00 .1E+02 6 11 .136E+04 .22E-05 .21E-05 .2E-02 S .0E+00 .5E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .135683E+04 RELDX .170E-02 FUNC. EVALS 11 GRAD. EVALS 7 PRELDF .212E-05 NPRELDF .212E-05 I FINAL X(I) D(I) G(I) 1 -.476239E+01 .214E+02 .836E-03 2 .202246E+01 .470E+02 .337E-03 3 .164299E+01 .108E+02 .680E-03 4 .176276E+01 .156E+01 -.113E-03 5 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 5 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .21E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .528E-01 ROW 2 -.210E-01 .892E-02 ROW 3 -.193E-01 .684E-02 .275E-01 ROW 4 .175E-01 -.509E-02 .897E-01 .934 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .220 3.76 .125 .142 2.43 .359 .545 .164 .186 1.04 .301 .710E-01 1.11 .334 .106 DEVIANCE = 53.3353577 * 28 **** problem mn205 **** * 10 Example on p. 204-5 of McCullagh and Nelder * 7 Run 15: calling GLG with PS = 5 I INITIAL X(I) D(I) 1 .100000E+01 .106E+02 2 .100000E+01 .171E+02 3 .100000E+01 .634E+01 4 .100000E+01 .716E+00 5 .100000E+01 .609E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .366E+04 1 4 .177E+04 .52E+00 .62E+00 .3E+00 G .9E+01 .1E+02 2 7 .152E+04 .14E+00 .13E+00 .9E-01 G .2E+01 .9E+01 3 11 .146E+04 .38E-01 .34E-01 .1E-01 G .2E+01 .5E+01 4 12 .140E+04 .45E-01 .44E-01 .1E-01 G .1E+00 .2E+02 5 14 .136E+04 .27E-01 .29E-01 .1E-01 G .3E-01 .3E+02 6 15 .134E+04 .10E-01 .14E-01 .3E-01 G .0E+00 .4E+02 7 16 .134E+04 .35E-02 .49E-02 .5E-01 G .0E+00 .3E+02 8 17 .134E+04 .32E-04 .33E-04 .7E-02 G .0E+00 .2E+01 9 18 .134E+04 -.18E-06 .14E-08 .5E-04 G .0E+00 .1E-01 ***** X- AND RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .133952E+04 RELDX .460E-04 FUNC. EVALS 18 GRAD. EVALS 9 PRELDF .142E-08 NPRELDF .142E-08 I FINAL X(I) D(I) G(I) 1 -.289687E+01 .214E+02 -.605E-02 2 .134514E+01 .441E+02 .153E-01 3 .170841E+01 .983E+01 -.703E-02 4 .206077E+01 .140E+01 .623E-03 5 .167369E+01 .577E+02 .107E-01 6 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 6 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .22E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .613E-01 ROW 2 -.251E-01 .109E-01 ROW 3 -.135E-01 .480E-02 .310E-01 ROW 4 .254E-01 -.830E-02 .117 1.19 ROW 5 .216E-01 -.893E-02 -.589E-03 .750E-02 .126E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .641 2.70 .732E-01 .162E-01 1.08 1.07 .177 .465 .824E-01 .176 .178E-02 .154E-01 .276E-02 .458E-01 .199E-01 DEVIANCE = 18.6993561 * 28 **** problem mn205.1 **** * 10 Example on p. 205-6 of McCullagh and Nelder * 7 Run 16: calling GLG with PS = 5 I INITIAL X(I) D(I) 1 -.289600E+01 .210E+02 2 .134500E+01 .431E+02 3 .170800E+01 .957E+01 4 .167400E+01 .151E+01 5 .198000E+01 .418E+02 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .138E+04 1 2 .137E+04 .11E-01 .15E-01 .5E-02 G .3E+02 .9E+00 2 4 .135E+04 .11E-01 .17E-01 .1E-01 G .7E+01 .2E+01 3 5 .134E+04 .58E-02 .68E-02 .1E-01 G .1E+00 .8E+01 4 6 .134E+04 .26E-02 .33E-02 .3E-01 G .3E-01 .8E+01 5 7 .134E+04 .35E-03 .37E-03 .2E-01 G .0E+00 .7E+01 6 8 .134E+04 .46E-05 .45E-05 .3E-02 G .0E+00 .4E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .133952E+04 RELDX .251E-02 FUNC. EVALS 8 GRAD. EVALS 7 PRELDF .449E-05 NPRELDF .449E-05 I FINAL X(I) D(I) G(I) 1 -.289664E+01 .214E+02 -.111E-02 2 .134504E+01 .440E+02 .355E-02 3 .170842E+01 .982E+01 -.142E-02 4 .206098E+01 .140E+01 .145E-03 5 .167374E+01 .198E+02 -.206E-02 6 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 6 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .22E-01 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .613E-01 ROW 2 -.251E-01 .109E-01 ROW 3 -.134E-01 .479E-02 .311E-01 ROW 4 .256E-01 -.839E-02 .117 1.19 ROW 5 .216E-01 -.893E-02 -.583E-03 .754E-02 .126E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .641 2.70 .733E-01 .162E-01 1.07 1.07 .177 .466 .827E-01 .176 .177E-02 .154E-01 .274E-02 .461E-01 .200E-01 DEVIANCE = 18.6996002 * 28 **** problem speed **** * 10 Speed data from Daryl(14.2): E(y)=b*x+c*x^2, var(y) = phi*E(y)^theta * 7 Run 17: calling GLG with PS = 2 I INITIAL X(I) D(I) 1 .123903E+01 .115E+03 2 .901387E-01 .219E+04 3 .100000E+01 .104E+03 4 .000000E+00 .292E+03 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .546E+04 1 3 .525E+04 .39E-01 .39E-01 .5E-02 G .3E+02 .2E+01 2 6 .203E+04 .61E+00 .49E+00 .2E+00 G .0E+00 .7E+02 3 7 .834E+03 .59E+00 .47E+00 .2E+00 G .0E+00 .4E+02 4 8 .402E+03 .52E+00 .41E+00 .2E+00 G .0E+00 .3E+02 5 9 .253E+03 .37E+00 .30E+00 .1E+00 G .0E+00 .2E+02 6 10 .208E+03 .18E+00 .14E+00 .9E-01 G .0E+00 .8E+01 7 11 .198E+03 .46E-01 .40E-01 .6E-01 G .0E+00 .4E+01 8 12 .198E+03 .44E-02 .41E-02 .2E-01 G .0E+00 .1E+01 9 13 .198E+03 .15E-03 .12E-03 .1E-01 G .0E+00 .7E+00 10 14 .198E+03 .34E-04 .30E-04 .1E-01 G .0E+00 .6E+00 11 15 .198E+03 .36E-05 .31E-05 .3E-02 G .0E+00 .2E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .197503E+03 RELDX .280E-02 FUNC. EVALS 15 GRAD. EVALS 12 PRELDF .307E-05 NPRELDF .307E-05 I FINAL X(I) D(I) G(I) 1 .127455E+01 .765E+01 -.508E-05 2 .882853E-01 .125E+03 -.326E-03 3 .141924E+01 .352E+01 -.910E-02 4 .133250E+01 .180E+02 -.328E-01 5 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 5 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .57E-02 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .179 ROW 2 -.104E-01 .671E-03 ROW 3 .117E-01 -.642E-03 2.04 ROW 4 -.237E-02 .130E-03 -.390 .778E-01 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .509 .500E-01 -1.00 .114 .635E-02 .310E-01 .770E-02 .841E-02 .586E-01 .124E-01 .588E-02 .384E-01 .967E-02 .574E-02 .476E-02 .567E-02 .505E-02 .505E-02 .228E-01 .694E-02 .498E-02 2.48 -1.00 .384E-01 .106E-01 .139E-01 .667E-02 .520E-02 .122E-01 .538E-02 .609E-02 .628E-02 .676E-02 .380E-01 -1.00 .293E-01 .719E-02 .102E-01 -1.00 .100E-01 .763E-02 .702E-02 .770E-02 .844E-02 .421E-01 .145E-01 .160E-01 .173E-01 1.26 .102E-01 DEVIANCE = 70.9987030 * 28 **** problem textile **** * 10 textile data from Daryl: E(y) = exp(b0+x1*b1+x2*b2+x3*b3), Var(y) = mu^ * 7 Run 18: calling GLG with PS = 4 I INITIAL X(I) D(I) 1 .633467E+01 .601E+04 2 .832380E+00 .553E+04 3 -.630993E+00 .535E+04 4 -.392494E+00 .512E+04 5 .100000E+01 .106E+04 6 .000000E+00 .563E+04 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .562E+06 1 4 .557E+06 .95E-02 .95E-02 .5E-04 G .2E+03 .5E+01 2 8 .403E+06 .28E+00 .27E+00 .2E-02 G .3E+01 .2E+03 3 9 .160E+06 .60E+00 .49E+00 .8E-02 G .8E-01 .5E+03 4 10 .592E+05 .63E+00 .50E+00 .1E-01 G .0E+00 .4E+03 5 11 .219E+05 .63E+00 .50E+00 .1E-01 G .0E+00 .3E+03 6 12 .816E+04 .63E+00 .50E+00 .1E-01 G .0E+00 .2E+03 7 13 .309E+04 .62E+00 .49E+00 .1E-01 G .0E+00 .9E+02 8 14 .122E+04 .61E+00 .48E+00 .1E-01 G .0E+00 .6E+02 9 15 .530E+03 .56E+00 .45E+00 .1E-01 G .0E+00 .3E+02 10 16 .282E+03 .47E+00 .37E+00 .1E-01 G .0E+00 .2E+02 11 17 .197E+03 .30E+00 .24E+00 .1E-01 G .0E+00 .1E+02 12 18 .171E+03 .13E+00 .11E+00 .8E-02 G .0E+00 .6E+01 13 19 .165E+03 .36E-01 .30E-01 .6E-02 G .0E+00 .3E+01 14 20 .164E+03 .68E-02 .54E-02 .5E-02 G .0E+00 .3E+01 15 23 .164E+03 .83E-03 .82E-03 .1E-02 G .4E+00 .5E+00 16 25 .164E+03 .12E-02 .12E-02 .2E-02 G .5E-01 .1E+01 17 27 .163E+03 .48E-03 .48E-03 .9E-03 G .4E+00 .4E+00 18 29 .163E+03 .99E-03 .99E-03 .2E-02 G .6E-01 .9E+00 19 31 .163E+03 .83E-03 .82E-03 .1E-02 G .2E+00 .8E+00 20 33 .163E+03 .17E-02 .18E-02 .3E-02 G .3E-01 .2E+01 21 35 .163E+03 .47E-03 .27E-02 .6E-02 G .3E-01 .3E+01 22 36 .162E+03 .47E-02 .40E-02 .4E-02 G .0E+00 .2E+01 23 39 .162E+03 .75E-03 .73E-03 .2E-02 G .1E+00 .9E+00 24 40 .162E+03 .13E-02 .15E-02 .3E-02 G .7E-01 .2E+01 25 42 .162E+03 .12E-02 .10E-02 .3E-02 G .6E-01 .1E+01 26 44 .161E+03 .11E-02 .12E-02 .3E-02 G .5E-01 .2E+01 27 45 .161E+03 .11E-02 .71E-03 .3E-02 G .0E+00 .2E+01 28 47 .161E+03 .54E-03 .51E-03 .2E-02 G .9E-01 .8E+00 29 53 .161E+03 .70E-03 .86E-03 .3E-02 G .5E-01 .2E+01 30 54 .161E+03 .79E-03 .73E-03 .4E-02 G .0E+00 .2E+01 31 55 .161E+03 .85E-03 .68E-03 .3E-02 G .0E+00 .1E+01 32 57 .161E+03 .14E-03 .14E-03 .8E-03 G .1E+00 .4E+00 33 59 .161E+03 .27E-03 .30E-03 .2E-02 G .4E-01 .1E+01 34 61 .161E+03 .17E-03 .16E-03 .1E-02 G .5E-01 .6E+00 35 64 .161E+03 .21E-03 .23E-03 .2E-02 G .3E-01 .1E+01 36 65 .161E+03 .16E-03 .18E-03 .3E-02 G .0E+00 .2E+01 37 66 .161E+03 .19E-03 .17E-03 .1E-02 G .0E+00 .7E+00 38 68 .161E+03 .27E-04 .26E-04 .6E-03 G .3E-01 .3E+00 39 70 .161E+03 .38E-04 .41E-04 .1E-02 G .4E-02 .7E+00 40 71 .161E+03 .24E-04 .21E-04 .1E-02 G .0E+00 .7E+00 41 72 .161E+03 .75E-05 .66E-05 .5E-03 G .0E+00 .3E+00 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .160510E+03 RELDX .510E-03 FUNC. EVALS 72 GRAD. EVALS 42 PRELDF .659E-05 NPRELDF .659E-05 I FINAL X(I) D(I) G(I) 1 .634777E+01 .332E+02 .564E-03 2 .840771E+00 .265E+02 .118E-01 3 -.628691E+00 .267E+02 .122E-02 4 -.371045E+00 .269E+02 .190E-02 5 .127625E-02 .288E+04 -.867E+01 6 .248075E+01 .235E+02 -.109E+00 7 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 7 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF F.D. HESSIAN) = AT MOST .91E-03 COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIAN ROW 1 .109E-02 ROW 2 .390E-03 .155E-02 ROW 3 -.285E-03 .152E-04 .147E-02 ROW 4 -.160E-03 .130E-03 -.305E-04 .168E-02 ROW 5 .444E-05 -.177E-05 .700E-05 -.507E-04 .100E-04 ROW 6 -.544E-03 .222E-03 -.869E-03 .628E-02 -.123E-02 .152 REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * G(I). .995E-02 -1.00 .625E-01 .209E-01 .253E-01 -1.00 .172 .115 .962E-02 .180E-01 .238E-01 .562E-01 -1.00 .108E-01 .362E-01 .859E-02 .274E-01 .239E-01 .191E-01 .713 .722E-01 .438E-01 .525E-01 -1.00 .497E-01 -1.00 -1.00 DEVIANCE = 3.44869755E-02 * 28 **** problem insurance (D = I) **** * 10 Insurance data from Daryl. * 2 * 3 * 5 * 11 Changing RHO from 11 to 13 * 7 Run 19: calling GLG with PS = 14 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .000000E+00 .100E+01 5 .000000E+00 .100E+01 6 .000000E+00 .100E+01 7 .000000E+00 .100E+01 8 .000000E+00 .100E+01 9 .000000E+00 .100E+01 10 .000000E+00 .100E+01 11 .000000E+00 .100E+01 12 .000000E+00 .100E+01 13 .000000E+00 .100E+01 14 .100000E+01 .100E+01 15 .100000E+01 .100E+01 16 .200000E+01 .100E+01 17 -.100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .210E+07 1 3 .643E+06 .69E+00 .82E+00 .7E-01 G .8E+07 .5E+00 2 5 .180E+06 .72E+00 .76E+00 .4E-01 G .6E+07 .3E+00 3 9 .105E+06 .42E+00 .42E+00 .1E-01 G .1E+08 .7E-01 4 14 .969E+05 .74E-01 .74E-01 .2E-02 G .8E+08 .1E-01 5 18 .950E+05 .19E-01 .19E-01 .4E-03 G .3E+09 .2E-02 6 22 .946E+05 .46E-02 .47E-02 .1E-03 G .1E+10 .6E-03 7 26 .829E+05 .12E+00 .12E+00 .3E-02 G .5E+07 .2E-01 8 28 .644E+05 .22E+00 .22E+00 .6E-02 G .1E+08 .4E-01 9 32 .602E+05 .65E-01 .65E-01 .2E-02 G .4E+08 .1E-01 10 34 .528E+05 .12E+00 .12E+00 .3E-02 G .3E+07 .2E-01 11 39 .512E+05 .30E-01 .30E-01 .7E-03 G .7E+08 .5E-02 12 41 .485E+05 .54E-01 .54E-01 .1E-02 G .7E+07 .9E-02 13 43 .395E+05 .19E+00 .19E+00 .5E-02 G .8E+06 .3E-01 14 45 .538E+04 .86E+00 .91E+00 .4E-01 G .2E+06 .3E+00 15 47 .112E+04 .79E+00 .85E+00 .2E-01 G .1E+06 .1E+00 16 49 .818E+03 .27E+00 .28E+00 .1E-01 G .2E+05 .8E-01 17 50 .680E+03 .17E+00 .22E+00 .1E-01 G .2E+05 .8E-01 18 51 .656E+03 .35E-01 .43E-01 .2E-01 G .3E+04 .8E-01 19 52 .637E+03 .30E-01 .34E-01 .2E-01 G .3E+04 .8E-01 20 53 .625E+03 .19E-01 .22E-01 .2E-01 G .1E+04 .8E-01 21 54 .622E+03 .49E-02 .62E-02 .2E-01 G .1E+03 .7E-01 22 55 .621E+03 .30E-03 .39E-03 .1E-02 G .1E+03 .8E-02 23 58 .621E+03 .59E-06 .81E-05 .3E-03 G .4E+03 .1E-02 - 24 59 .621E+03 .63E-05 .14E-04 .2E-03 G .2E+05 .6E-03 25 60 .621E+03 -.22E-05 .91E-06 .1E-03 G .2E+03 .6E-03 - ***** SINGULAR CONVERGENCE ***** FUNCTION .621422E+03 RELDX .130E-03 FUNC. EVALS 60 GRAD. EVALS 25 PRELDF .909E-06 NPRELDF -.247E-05 I FINAL X(I) D(I) G(I) 1 -.118296E-02 .100E+01 -.413E-01 2 -.103054E-02 .100E+01 -.225E-01 3 -.553834E-03 .100E+01 .736E-02 4 -.318949E-03 .100E+01 .592E-02 5 .136577E-02 .100E+01 .301E-02 6 .640669E-03 .100E+01 .508E-01 7 .533043E-03 .100E+01 .278E-01 8 .954079E-03 .100E+01 -.270E-01 9 .101301E-02 .100E+01 .788E-01 10 -.204215E-03 .100E+01 .569E-01 11 -.276228E-02 .100E+01 .198E+00 12 -.207975E-02 .100E+01 .140E+00 13 .256401E-03 .100E+01 .140E-01 14 .106218E-01 .100E+01 .372E+00 15 .931680E+00 .100E+01 -.169E+00 16 .201545E+01 .100E+01 -.118E+01 17 -.116459E+01 .100E+01 .360E+00 DEVIANCE = 114.571899 * 28 **** problem insurance.1 (D = I) **** * 5 * 7 Run 20: calling GLG with PS = 14 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 .000000E+00 .100E+01 2 .000000E+00 .100E+01 3 .000000E+00 .100E+01 4 .000000E+00 .100E+01 5 .000000E+00 .100E+01 6 .000000E+00 .100E+01 7 .000000E+00 .100E+01 8 .000000E+00 .100E+01 9 .000000E+00 .100E+01 10 .000000E+00 .100E+01 11 .000000E+00 .100E+01 12 .000000E+00 .100E+01 13 .000000E+00 .100E+01 14 .100000E+01 .100E+01 15 .100000E+01 .100E+01 16 .150000E+01 .100E+01 17 -.100000E+01 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .379E+07 1 3 .133E+07 .65E+00 .64E+00 .1E+00 G .8E+07 .5E+00 2 7 .729E+06 .45E+00 .46E+00 .3E-01 G .2E+08 .2E+00 3 10 .450E+06 .38E+00 .39E+00 .2E-01 G .4E+08 .9E-01 4 14 .381E+06 .15E+00 .15E+00 .5E-02 G .1E+09 .2E-01 5 18 .365E+06 .43E-01 .43E-01 .1E-02 G .4E+09 .6E-02 6 21 .357E+06 .21E-01 .21E-01 .6E-03 G .8E+09 .3E-02 7 24 .308E+06 .14E+00 .14E+00 .4E-02 G .1E+08 .3E-01 8 27 .265E+06 .14E+00 .14E+00 .4E-02 G .7E+08 .2E-01 9 29 .228E+06 .14E+00 .14E+00 .4E-02 G .6E+08 .2E-01 10 31 .170E+06 .26E+00 .26E+00 .8E-02 G .4E+07 .5E-01 11 33 .886E+05 .48E+00 .52E+00 .2E-01 G .6E+07 .1E+00 12 37 .791E+05 .11E+00 .11E+00 .2E-02 G .3E+08 .2E-01 13 39 .727E+05 .82E-01 .85E-01 .2E-02 G .6E+07 .2E-01 14 41 .601E+05 .17E+00 .17E+00 .5E-02 G .1E+07 .4E-01 15 44 .491E+05 .18E+00 .18E+00 .6E-02 G .5E+07 .5E-01 16 46 .327E+05 .33E+00 .34E+00 .1E-01 G .3E+06 .9E-01 17 48 .957E+04 .71E+00 .76E+00 .3E-01 G .5E+06 .2E+00 18 50 .248E+04 .74E+00 .77E+00 .1E-01 G .5E+06 .1E+00 19 53 .127E+04 .49E+00 .49E+00 .4E-02 G .8E+06 .3E-01 20 54 .751E+03 .41E+00 .41E+00 .7E-02 G .2E+06 .3E-01 21 56 .630E+03 .16E+00 .17E+00 .4E-02 G .1E+06 .2E-01 22 57 .626E+03 .76E-02 .80E-02 .4E-02 G .7E+04 .2E-01 23 59 .622E+03 .62E-02 .69E-02 .2E-01 G .2E+03 .7E-01 24 60 .622E+03 .29E-04 .36E-04 .1E-02 G .2E+03 .7E-02 25 61 .622E+03 .79E-04 .38E-04 .2E-01 G .1E+01 .7E-01 26 62 .622E+03 .33E-04 .78E-04 .6E-02 G .6E+02 .3E-01 27 70 .622E+03 .11E-04 .48E-05 .3E-04 G .3E+06 .1E-03 - 28 71 .622E+03 .19E-04 .25E-05 .3E-04 G .4E+05 .1E-03 29 74 .622E+03 -.27E-04 .17E-07 .9E-06 G .6E+06 .4E-05 - ***** FALSE CONVERGENCE ***** FUNCTION .621513E+03 RELDX .867E-06 FUNC. EVALS 74 GRAD. EVALS 29 PRELDF .170E-07 NPRELDF -.226E+00 I FINAL X(I) D(I) G(I) 1 -.179679E-02 .100E+01 -.866E-02 2 -.159230E-02 .100E+01 -.137E-02 3 -.857463E-03 .100E+01 .171E-02 4 -.479661E-03 .100E+01 .378E-03 5 .207224E-02 .100E+01 .395E-02 6 .989622E-03 .100E+01 .502E-02 7 .819189E-03 .100E+01 -.484E-03 8 .146934E-02 .100E+01 -.632E-02 9 .155042E-02 .100E+01 .693E-02 10 -.298028E-03 .100E+01 .942E-02 11 -.407997E-02 .100E+01 .221E-01 12 -.304275E-02 .100E+01 .197E-01 13 .441976E-03 .100E+01 .335E-02 14 .177463E-01 .100E+01 .470E-01 15 .107096E+01 .100E+01 .141E+01 16 .199416E+01 .100E+01 -.209E+01 17 -.131501E+01 .100E+01 .236E-01 //GO.SYSIN DD spmain.sgi cat >srent1.sgi <<'//GO.SYSIN DD srent1.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 21 FIXED BLOCK SIZE: 27 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .86E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .17E-03 .87E-03 .3E-01 G .0E+00 .1E+00 3 4 .415E+03 .35E-04 .17E-04 .2E-02 G .0E+00 .1E-01 4 5 .415E+03 -.13E-04 .16E-05 .1E-02 G .0E+00 .5E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .415069E+03 RELDX .127E-02 FUNC. EVALS 5 GRAD. EVALS 4 PRELDF .162E-05 NPRELDF .162E-05 I FINAL X(I) D(I) G(I) 1 -.404306E-02 .100E+01 -.125E+02 2 .732337E-02 .100E+01 .217E-02 3 -.410103E+00 .100E+01 -.891E-01 4 .800799E+00 .100E+01 -.101E-01 5 .734643E+00 .100E+01 .102E+00 6 -.153814E+01 .100E+01 -.153E+00 7 -.690819E+00 .100E+01 .113E+00 8 .522076E+00 .100E+01 -.130E+00 9 .100965E+01 .100E+01 .184E+00 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .15E-02 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .119E-06 ROW 2 .629E-05 .139E-01 ROW 3 .770E-05 .746E-02 .207E-01 ROW 4 -.496E-05 .912E-03 -.169E-02 .197E-01 ROW 5 -.625E-05 .120E-03 -.300E-02 .108E-01 .184E-01 ROW 6 .187E-04 -.843E-03 -.105E-02 -.482E-02 -.609E-02 .231E-01 ROW 7 .893E-05 .102E-02 .160E-02 -.944E-03 -.112E-02 .645E-02 .126E-01 ROW 8 -.185E-04 .150E-02 -.130E-02 .225E-02 .382E-02 -.307E-02 -.224E-02 .157E-01 ROW 9 -.121E-04 -.418E-03 .610E-04 .326E-02 .499E-03 -.402E-02 -.130E-02 .630E-02 .937E-02 BLOCK REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * BLOCK FIRST LAST RD(I) X(I) 1 1 27 1.36 -.419623E-02 .107538E-01 -.449216 .746156 .701973 -1.38556 -.674800 .514925 1.04434 2 28 54 1.38 -.382634E-02 .723168E-01 -.396079 .931122 .759240 -1.47708 -.592506 .471300 1.04549 3 55 81 2.34 -.385073E-02 .949891E-01 -.426277 .712319 .585146 -1.56107 -.614284 .443285 1.05948 4 82 108 .763 -.405100E-02 -.424883E-01 -.436696 .855154 .823027 -1.46205 -.626776 .509012 .964965 5 109 135 .389 -.403471E-02 -.152946E-01 -.467404 .718665 .651784 -1.50322 -.704048 .530019 1.01721 6 136 162 .725 -.408811E-02 .407342E-01 -.365088 .859776 .788900 -1.46719 -.610074 .521843 .975489 7 163 189 .592 -.388656E-02 .261319E-01 -.326041 .840804 .783141 -1.49909 -.669586 .551541 1.03998 8 190 216 .207 -.399037E-02 .755204E-02 -.386460 .752136 .665622 -1.47974 -.693940 .485710 .985298 9 217 243 2.03 -.408137E-02 -.495192E-01 -.379740 .851146 .717372 -1.70290 -.696312 .577077 .994407 10 244 270 .517 -.400896E-02 -.771409E-01 -.421450 .808178 .749354 -1.59105 -.696039 .519338 .994920 11 271 297 .393 -.413026E-02 -.703875E-01 -.475711 .826084 .769811 -1.50636 -.695424 .568541 1.03838 12 298 324 .798 -.402404E-02 .690264E-01 -.336626 .798751 .670751 -1.53125 -.753028 .560149 .984322 13 325 351 .178 -.394664E-02 .177254E-01 -.419119 .749785 .714677 -1.48342 -.651237 .507435 .998476 14 352 378 22.5 -.505603E-02 .215080 -.292947 .972436 1.07700 -2.12741 -1.08548 .569616 1.31075 15 379 405 .274 -.402545E-02 .495496E-02 -.378541 .747910 .704932 -1.49607 -.689299 .457434 .973859 16 406 432 1.03 -.403836E-02 -.738488E-01 -.447706 .878803 .830963 -1.50284 -.689564 .447401 .939389 17 433 459 2.39 -.413379E-02 .959710E-01 -.264256 .717704 .793823 -1.72213 -.678043 .614645 .994633 18 460 486 .302 -.395342E-02 -.196734E-01 -.450787 .745831 .703221 -1.49774 -.725355 .513449 1.01505 19 487 513 8.09 -.428471E-02 .527988E-01 -.770413 .886322 .774364 -1.81399 -.754707 .662258 .985671 20 514 540 .424 -.425403E-02 -.168940E-01 -.369987 .818497 .729111 -1.54562 -.711059 .511408 1.03190 21 541 567 .511 -.396609E-02 -.304000E-01 -.408074 .791827 .687352 -1.50203 -.742298 .529089 .976537 ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 RENT -.404306E-02 -.117071E+02 .345350E-03 2 LocD1 .732337E-02 .620960E-01 .117936E+00 3 LocD2 -.410103E+00 -.285219E+01 .143785E+00 4 ConD1 .800799E+00 .570038E+01 .140482E+00 5 ConD2 .734643E+00 .541762E+01 .135603E+00 6 BedD1 -.153814E+01 -.101252E+02 .151912E+00 7 BedD2 -.690819E+00 -.614890E+01 .112348E+00 8 Htype .522076E+00 .416570E+01 .125327E+00 9 CDum .100965E+01 .104309E+02 .967945E-01 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.415069E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415689E+03 1 - L(EST)/L(0): = .333665E+00 1 - (L(EST)-NPAR)/L(0) = .319217E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301292E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.404306E-02 -.100000E+03 .100000E+03 LocD1 .732337E-02 -.100000E+03 .100000E+03 LocD2 -.410103E+00 -.100000E+03 .100000E+03 ConD1 .800799E+00 -.100000E+03 .100000E+03 ConD2 .734643E+00 -.100000E+03 .100000E+03 BedD1 -.153814E+01 -.100000E+03 .100000E+03 BedD2 -.690819E+00 -.100000E+03 .100000E+03 Htype .522076E+00 -.100000E+03 .100000E+03 CDum .100965E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD srent1.sgi cat >srent1b.sgi <<'//GO.SYSIN DD srent1b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 21 FIXED BLOCK SIZE: 27 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .86E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .17E-03 .87E-03 .3E-01 G .0E+00 .1E+00 3 4 .415E+03 .35E-04 .17E-04 .2E-02 G .0E+00 .1E-01 4 5 .415E+03 -.13E-04 .16E-05 .1E-02 G .0E+00 .5E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .415069E+03 RELDX .127E-02 FUNC. EVALS 5 GRAD. EVALS 4 PRELDF .162E-05 NPRELDF .162E-05 I FINAL X(I) D(I) G(I) 1 -.404306E-02 .100E+01 -.188E+02 2 .732337E-02 .100E+01 -.197E-03 3 -.410103E+00 .100E+01 -.823E-01 4 .800799E+00 .100E+01 -.182E-01 5 .734643E+00 .100E+01 .102E+00 6 -.153814E+01 .100E+01 -.155E+00 7 -.690819E+00 .100E+01 .123E+00 8 .522076E+00 .100E+01 -.137E+00 9 .100965E+01 .100E+01 .183E+00 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.415069E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415689E+03 1 - L(EST)/L(0): = .333665E+00 1 - (L(EST)-NPAR)/L(0) = .319217E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301292E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.404306E-02 -.100000E+03 .100000E+03 LocD1 .732337E-02 -.100000E+03 .100000E+03 LocD2 -.410103E+00 -.100000E+03 .100000E+03 ConD1 .800799E+00 -.100000E+03 .100000E+03 ConD2 .734643E+00 -.100000E+03 .100000E+03 BedD1 -.153814E+01 -.100000E+03 .100000E+03 BedD2 -.690819E+00 -.100000E+03 .100000E+03 Htype .522076E+00 -.100000E+03 .100000E+03 CDum .100965E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD srent1b.sgi cat >srent2.sgi <<'//GO.SYSIN DD srent2.sgi' PROGRAM MLMNP MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS NOT ENFORCED; STATISTICS ARE COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 3 VARIABLE BLOCK-SIZE OPTION CHOSEN BLOCK-SIZES: 216 162 189 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .86E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .17E-03 .87E-03 .3E-01 G .0E+00 .1E+00 3 4 .415E+03 .35E-04 .17E-04 .2E-02 G .0E+00 .1E-01 4 5 .415E+03 -.13E-04 .16E-05 .1E-02 G .0E+00 .5E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .415069E+03 RELDX .127E-02 FUNC. EVALS 5 GRAD. EVALS 4 PRELDF .162E-05 NPRELDF .162E-05 I FINAL X(I) D(I) G(I) 1 -.404306E-02 .100E+01 -.125E+02 2 .732337E-02 .100E+01 .217E-02 3 -.410103E+00 .100E+01 -.891E-01 4 .800799E+00 .100E+01 -.101E-01 5 .734643E+00 .100E+01 .102E+00 6 -.153814E+01 .100E+01 -.153E+00 7 -.690819E+00 .100E+01 .113E+00 8 .522076E+00 .100E+01 -.130E+00 9 .100965E+01 .100E+01 .184E+00 1 EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOSTICS. 1 EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTICS. SQRT(RECIPROCAL CONDITION OF (J**T)*RHO"*J) = AT MOST .15E-02 COVARIANCE = (J**T * RHO" * J)**-1 ROW 1 .119E-06 ROW 2 .629E-05 .139E-01 ROW 3 .770E-05 .746E-02 .207E-01 ROW 4 -.496E-05 .912E-03 -.169E-02 .197E-01 ROW 5 -.625E-05 .120E-03 -.300E-02 .108E-01 .184E-01 ROW 6 .187E-04 -.843E-03 -.105E-02 -.482E-02 -.609E-02 .231E-01 ROW 7 .893E-05 .102E-02 .160E-02 -.944E-03 -.112E-02 .645E-02 .126E-01 ROW 8 -.185E-04 .150E-02 -.130E-02 .225E-02 .382E-02 -.307E-02 -.224E-02 .157E-01 ROW 9 -.121E-04 -.418E-03 .610E-04 .326E-02 .499E-03 -.402E-02 -.130E-02 .630E-02 .937E-02 BLOCK REGRESSION DIAGNOSTIC = 0.5 * G(I)**T * H(I)**-1 * H * H(I)**-1 * BLOCK FIRST LAST RD(I) X(I) 1 1 216 18.8 -.348599E-02 .200375 -.414902 .817920 .539443 -.944800 -.243386 .305673 1.09175 2 217 378 13.1 -.489388E-02 -.467130E-01 -.272621 1.00380 .943325 -2.20397 -1.05524 .718091 1.23670 3 379 567 7.97 -.436072E-02 -.115569E-01 -.577420 .688564 .792257 -1.82213 -.860829 .563143 .808891 ASYMPTOTIC T-STATISTICS: I X(I) T-STAT(I) STD ERROR 1 RENT -.404306E-02 -.117071E+02 .345350E-03 2 LocD1 .732337E-02 .620960E-01 .117936E+00 3 LocD2 -.410103E+00 -.285219E+01 .143785E+00 4 ConD1 .800799E+00 .570038E+01 .140482E+00 5 ConD2 .734643E+00 .541762E+01 .135603E+00 6 BedD1 -.153814E+01 -.101252E+02 .151912E+00 7 BedD2 -.690819E+00 -.614890E+01 .112348E+00 8 Htype .522076E+00 .416570E+01 .125327E+00 9 CDum .100965E+01 .104309E+02 .967945E-01 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.415069E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415689E+03 1 - L(EST)/L(0): = .333665E+00 1 - (L(EST)-NPAR)/L(0) = .319217E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301292E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.404306E-02 -.100000E+03 .100000E+03 LocD1 .732337E-02 -.100000E+03 .100000E+03 LocD2 -.410103E+00 -.100000E+03 .100000E+03 ConD1 .800799E+00 -.100000E+03 .100000E+03 ConD2 .734643E+00 -.100000E+03 .100000E+03 BedD1 -.153814E+01 -.100000E+03 .100000E+03 BedD2 -.690819E+00 -.100000E+03 .100000E+03 Htype .522076E+00 -.100000E+03 .100000E+03 CDum .100965E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD srent2.sgi cat >srent2b.sgi <<'//GO.SYSIN DD srent2b.sgi' PROGRAM MLMNPB MAXIMUM LIKELIHOOD ESTIMATION OF LINEAR-IN-PARAMETERS MULTINOMIAL PROBIT MODELS (BOUNDS ARE ENFORCED; STATISTICS ARE NOT COMPUTED) NUMBER OF OBSERVATIONS................. 567 NUMBER OF ALTERNATIVES PER CHOICE SET.. 3 EQUAL WEIGHTS FOR ALL OBSERVATIONS NO INTEGER EXPLANATORY VARIABLES NUMBER OF REAL DATA VALUES PER OBS..... 27 OUTPUT UNIT............................ 6 COVARIANCE TYPE = INVERSE GAUSS-NEWTON HESSIAN REGRESSION DIAGNOSTICS REQUESTED *** LEAVE-BLOCK-OUT DIAGNOSTICS REQUESTED *** DIAGNOSTICS ON X-VECTOR REQUESTED NUMBER OF BLOCKS: 3 VARIABLE BLOCK-SIZE OPTION CHOSEN BLOCK-SIZES: 216 162 189 *** NOTE: NALT SET EQUAL TO ICSET *** NUMBER OF NOMINAL VARIABLES............ 3 NUMBER OF ATTRIBUTES PER ALTERNATIVE... 9 NO NOMINAL DUMMIES IID ERROR TERMS NO RANDOM TASTE VARIATION NUMBER OF MODEL PARAMETERS............. 9 INITIAL PARAMETER VECTOR AND BOUNDS: 1 RENT -.371499E-02 -.100000E+03 .100000E+03 2 LocD1 .473069E-01 -.100000E+03 .100000E+03 3 LocD2 -.443496E+00 -.100000E+03 .100000E+03 4 ConD1 .734521E+00 -.100000E+03 .100000E+03 5 ConD2 .648764E+00 -.100000E+03 .100000E+03 6 BedD1 -.125812E+01 -.100000E+03 .100000E+03 7 BedD2 -.641347E+00 -.100000E+03 .100000E+03 8 Htype .429202E+00 -.100000E+03 .100000E+03 9 CDum .958062E+00 -.100000E+03 .100000E+03 NONDEFAULT VALUES.... DTYPE..... IV(16) = 0 DINIT..... V(38) = .1000000E+01 I INITIAL X(I) D(I) 1 -.371499E-02 .100E+01 2 .473069E-01 .100E+01 3 -.443496E+00 .100E+01 4 .734521E+00 .100E+01 5 .648764E+00 .100E+01 6 -.125812E+01 .100E+01 7 -.641347E+00 .100E+01 8 .429202E+00 .100E+01 9 .958062E+00 .100E+01 IT NF F RELDF PRELDF RELDX MODEL STPPAR D*STEP 0 1 .418E+03 1 2 .415E+03 .65E-02 .86E-02 .1E+00 G .0E+00 .4E+00 2 3 .415E+03 .17E-03 .87E-03 .3E-01 G .0E+00 .1E+00 3 4 .415E+03 .35E-04 .17E-04 .2E-02 G .0E+00 .1E-01 4 5 .415E+03 -.13E-04 .16E-05 .1E-02 G .0E+00 .5E-02 ***** RELATIVE FUNCTION CONVERGENCE ***** FUNCTION .415069E+03 RELDX .127E-02 FUNC. EVALS 5 GRAD. EVALS 4 PRELDF .162E-05 NPRELDF .162E-05 I FINAL X(I) D(I) G(I) 1 -.404306E-02 .100E+01 -.188E+02 2 .732337E-02 .100E+01 -.197E-03 3 -.410103E+00 .100E+01 -.823E-01 4 .800799E+00 .100E+01 -.182E-01 5 .734643E+00 .100E+01 .102E+00 6 -.153814E+01 .100E+01 -.155E+00 7 -.690819E+00 .100E+01 .123E+00 8 .522076E+00 .100E+01 -.137E+00 9 .100965E+01 .100E+01 .183E+00 NUMBER OF OBSERVATIONS (NOBS) = 567 LOG-LIKELIHOOD L(EST) = -.415069E+03 LOG-LIKELIHOOD L(0) = -.622913E+03 -2[L(0) - L(EST)]: = .415689E+03 1 - L(EST)/L(0): = .333665E+00 1 - (L(EST)-NPAR)/L(0) = .319217E+00 (FIXED CHOICE SET SIZE) AGGREGATE CHOICES AND MARKET SHARES: 1 121.000 .2134 2 133.000 .2346 3 313.000 .5520 STATISTICS FOR CONSTANTS-ONLY MODEL: LOG-LIKELIHOOD L(C) = -.565715E+03 -2[L(C) - L(EST)]: = .301292E+03 OUTPUT FOR CONVENIENT RESTART: RENT -.404306E-02 -.100000E+03 .100000E+03 LocD1 .732337E-02 -.100000E+03 .100000E+03 LocD2 -.410103E+00 -.100000E+03 .100000E+03 ConD1 .800799E+00 -.100000E+03 .100000E+03 ConD2 .734643E+00 -.100000E+03 .100000E+03 BedD1 -.153814E+01 -.100000E+03 .100000E+03 BedD2 -.690819E+00 -.100000E+03 .100000E+03 Htype .522076E+00 -.100000E+03 .100000E+03 CDum .100965E+01 -.100000E+03 .100000E+03 //GO.SYSIN DD srent2b.sgi