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 <pmain.in >$@

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 <pmain.in >$@

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
